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A compiler for a subset of the Automated Data Processing 
Equipment Selection Office (ADPESO), EYPO-COBOL, has been 
implemented on a microcomputer. The implementation provides 
nucleus level constructs, interprogram communications, and 
file options from the ANSI COBOL package along with the 
PERFORM UNTIL, PERFORM VARYING and an enhanced version of 
the IE-THEN-ELSE construct that includes nesting and 
multiple program statements for both the "THEN" and "ELSE" 
clauses. These additional constructs from level two of ANSI 
COBOL provide for more flexibility and increased structural 
control. The language was implemented through a compiler and 
run-time package executing under the CP/M operating system 
of a Z-80 or an 8080 microcomputer-based system. Both the 
compiler and interpreter can be executed in 20K bytes of 
main memory. A program consisting of 5K bytes of symbol 
table entries can be supported on this size machine. 
Modification of the compiler and interpreter programs can be 
accomplished to take advantage of larger machines. The 
programs that make up the compiler and interpreter package 
require 50K bytes of disk storage. 
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I. INTRODUCTION 



A. . BACKGROUND 



The NPS MICRO-COBOL Compiler/Interpreter was initially 
(1976) [3] developed to demonstrate that it was feasible to 
implement a COBOL compiler on a microcomputer. It was known 
that the COBOL language used would have to he a subset of 
ANSI COECL because of the restriction imposed by the size of 
a microcomputer memory. A subset of ANSI COBOL, specifically 
the Navy's Automated Data Processing Equipment Selection 
Office (ADPESO) HYP0-C030L [4], was selected as the basis 
for the implementation. Additional motivation was provided 
by the DOD requirement that all computers used in a 
non-tactical environment be capable of executing COEOL 
programs . 

The previous work was directed toward six major areas: 
1.) selecting a suitable COBOL subset to operate on, 2.) 
developing the associated grammar for the language, 3.) 
determining what type of compiler to design, 4.) designing 
and coding the compiler, 5.) designing and coding the 
interpreter, and 6.) testing and debugging of the storage 
allocation and symbol table entries of the compiler. 

The choice of a suitable language was originally based 
on EYPO-COBOL, since this is a Department of the Navy 
approved subset of COEOL, designed to place 
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minimal 



requirements on a system for compiler support. Where 
possible, short constructs were used in the place of longer 
ones. Where more than one reserved word served the same 
function in COBOL the shortest form was used. There is no 
optional verhage in the language, and no duplicate 
constructs perform the same function. Limits were placed on 
all statements that had a variable input format so that all 
statements had a fixed maximum length. Where possible, such 
constructs were removed completely from the language. In 
addition, user defined identifier names were limited to 
twelve characters to reduce symbol table storage 
requirements . 

Bather than include the standard levels of 
implementation for all of the modules in EYPO-COBOL, 
constructs were included only as required. In addition to 
low level constructs, TEE PERFORM UNTIL was included to 
allow better program structure. Further justification for 
the manner of subsetting and a highly detailed description 
of each element of the language is contained in the 
EYPO-COBOL language specifications reference 3. 

The grammar for the MICRO-COEOL language was defined as 
LALR(l). The compiler design was based on a table-driven 
parser for the LALR(l) grammar. The algorithm used to 
develope the parse tables for the compiler was developed by 
W . R . Lalonge [20] . 

The basic design and coding of tne compiler and 
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interpreter was completed prior to the current thesis work 



by Scott Allan Craig [3]. Modification to the original 
thesis work was conducted by Phil Mylet [16]. Initial 
testing and debugging of Part One was conducted by Jim 
Farlee and Michael Rice[9] . 

3. OPERATING ENVIRONMENT 

The NPS MICRO-COBOL compiler and interpreter are 
designed to run under the CP/M operating system on an 3083 
or Z80 based microcomputer with at least 23K bytes of main 
memory. The compiler programs are designed to use no more 
than 14K bytes of main memory, while the interpreter nrograrr 
uses approximately 12K bytes. The compiler and interpreter 
require 50K bytes of disk storage for the programs that make 
up the compiler/interpreter package. For information on 
creating MICRO-COBOL source programs and CP/M see references 
5 and 6. 

C. GOALS AND OBJECTIVES 

The major goals of this work were 1.) Modify the 
existing compiler to allow use of the ABPESO validation test 
programs, 2.) Correct all known errors as outlined by Farlee 
and Rice[18l, 3.) Implement all constructs not previously 
implemented, 4.) Verify that NPS MICRO-COBOL met HYPO-COEOL 
standards, and 5.) Extend the existing compiler/interpreter 
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package with some of the more frequently used high level 
COBOL constructs . 

In addition to the above goals, it was considered 
beneficial to update and incorporate all previous 
documentation into the present NPS MICRO-COBOL 
compiler/interpreter documentation. This documentation is 
included in this thesis. 

D. PROBLEM DEFINITION 

For software performance assessment, a series of simple 
COBOL source programs and the Navy ADPESC FYPO-COBOL [4] 
validation test programs (HCCVS ) were compiled and execution 
was attempted. Initial results of the ADPESO validation test 
programs produced over 4P0 compile and run time errors. Some 
of the errors were known previously as outlined in the 
previous thesis work by Farley and Rice[9]. The elimination 
of these problems plus the goals outlined above formed the 
foundation for this thesis. 

E. PROBLEM SOLUTION 

The ADPESO validation test programs could not be used 
for testing the compiler/interpreter until three areas were 
corrected. 1.) File I/O was inadequate to generate usable 
intermediate code, 2.) the IF-THEN-ELSE construct would not 
allow multiple statements to be performed, and 3.) the Move 
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Numeric Edited command was not implemented. The file I/O 
problem was corrected by Doug Loskot [15] as a class project 
early in this thesis effort. A new IF-THEN-ELSE construct 
allowing the use of multiple statements in both the "TEEN’’ 
and ’’ELSE" clauses was implemented by Robert Hartel and Doug 
Stowers[19] as another class project. Implementation of the 
Move Numeric Edited command was completed by the author 
early in the thesis effort and allowed the validation test 
programs to be used for testing. 

Once the validation programs could be compiled and 
executed, testing and debugging continued at a more rapid 
pace. All the errors exposed by the test programs as well as 
the known errors outlined in Appendix G of Earlee and 
Rice[9] were corrected, with the exception of the tests 
dealing with the Interprogram Communication Module. 

The grammer in Part Two of the compiler was not 
constructed to allow the name of a called program to be 
stored. This required a change to the existing grammar. In 
addition to modifing the grammar for subroutine calls, a 
change to allow nesting I E-THEN-ELSE , NEXT SENTENCE option, 
the PERFORM VARYING verb, the COMPUTE verb and the logical 
operators "AND" and ”0R” were defined in the grammar. 

The grammar change was implemented in two steps. First 
the IF-THEN-FLSE statement, which included nesting and an 
END-IF clause, and the PERFORM VARYING statement was 
implemented as a class project by Carol Cagle [2]. The 
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present grammer is the result of the second change and 
includes the COMPUTE verb, logical operators, GIVING clause 
for the arithemetic operators and the change that enabled 
implementation of the Interprogram Communications module. In 
it's present form all of the specifications of FYP0-C030L 
are met or exceeded. In addition to the constructs 
previously mentioned the new grammar will be able make the 
environment division optional, handle null paragraphs 
(paragraphs with no statements) and multiple open, close, 
display, add, and subtract statements as well as 
multi-dimensional tables. Appendix G contains a list of 
constructs that have been defined in the grammar but not yet 
implemented . 

F . SYSTEM OVERVIEW 

NPS MICRO-COBOL is a compiler/interpreter package. The 
compiler consists of three modules that combine to produce 
two files. The first file is an intermediate code file and 
the second is a list file containing any compilation errors 
and the line that caused the error. The first and second 
modules are combined together to form a module called 
COBOL.COM. The commend COBOL ^file name> initiates the 
compilation sequence. The first module (PART I) opens the 
input file, list file and code file, moves the second 
module, READER, to high memory for later use, and then 
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starts compiling the input file through the word PROCEDURE 
in the sentence PROCEDURE DIVISION. The symbol table is 
built starting at a storage location just above PART I and 
can use all available memory up to the base of the READER 
routine previously moved to high memory. After PROCEDURE is 
parsed control is transfered to the READER routine which 
then copies the third module (PART II), into memory over 
PART I. Compilation continues to the end of the input file 
using the symbol table constructed from PART I. The symbol 
table can be added to by PART II up to and including the 
area previously used by the READER routine as READER is no 
longer needed. This scheme allows the use of all available 
free memory for the symbol table. At the end of the input 
file all files are closed and the compilation process is 
complete . 

Error recovery/management is accomplished using the ad 
hoc panic mode technique discussed in Aho and Ullman [l] . 
Errors are ar.nouced to the user by a two letter code. Tne 
user is required to look up the meanings of these codes in 
order to understand the full significance of each error but 
it was felt that this technique was necessary to keep the 
size of the compiler/interpreter package to a minimum. 

The command EXEC <file name> causes the load routine 
BUILD to be loaded into memory. The BUILD routine opens the 
intermediate file created by the first phase and sets up the 
core image of the pseudo machine. Control transfers to the 
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INTRDR routine (Interpreter Reader) which reads the third 
module CINTERP into memory. This is the interpreter and once 
loaded control is passed to it and program execution degins. 
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II. N PS MICRO-COBOL COMPILER 



A. GENERAL DESCRIPTION 

The MICRO-COBOL compiler is a one pass compiler that 
scans and parses MICRO-COBOL source programs, and generates 
intermediate code (pseudo-instructions) for the interpreter 
(pseudo-machine). The scanner design is similar to most 
other scanner implementations. The parser is an LALR(l) 
table-driven design, implemented in the PLM80 programming 
language [10]. The parse tables, as stated before, were 
generated using an algorithm developed at the University of 
Toronto [20] . 

The compiler reads the source program from a disk file, 
extracts the needed information for the symbol table and 
writes pseudo-instructions to an intermediate code file. To 
accomplish this function, the compiler consists of three 
modules: PART ONE, PEADEP , and PART TWO. 

B. SYMBOL TABLE 

The symbol table is the key data structure in the 
compiler. Information concerning identifiers, files, and 
records specified in the DATA DIVISION of the MICRO-COBOL 
source program is stored in the symbol table, along with 
labels specified in the PROCEDURE DIVISION. 

The symbol table structure consists of: 1.) a sixty-four 
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address hash table, 2.) a fixed length field of fourteen 
bytes for each symbol table entry, and 3.) a variable length 
field to hold the name of each identifier. Since each 
identifier name is limited to fifteen ASCII characters the 
symbol table entry for identifiers can vary in length from 
fourteen to twenty-nine bytes. The bytes of each symbol 
table entry are grouped into various fields of either one or 
two bytes depending on the storage requirements. The 
fourteen bytes of the fixed length field entry are numbered 
from zero to thirteen and the variable length field begins 
with byte fourteen. In referencing a specific field a byte 
index with a value from zero to fourteen is utilized. 

The symbol table entry for a single identifier could 
contain up to nine different attributes of that identifier, 
although not all identifiers required the full range of 
attributes. The various fields in the symbol table contained 
different information depending on whether, for example, an 
identifier was a numeric or alphanumeric type. Four of the 
fields contained the same information for all identifiers. 
These fields were: 1.) field zero (bytes zero and one ) 
contained the collision link, 2.) field one (byte two) 
contained the type of the identifier, 3.) field two (byte 
three) contained the length of the identifier name, and 4.) 
field thirteen (byte fourteen) was the beginning of the 
ASCII character representation for the identifier name. It 
should be noted that an identifier of type FILLER would not 
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have a name associated with it, so field two would contain a 
zero and field fourteen would not exist. 

Entry into the symbol table is accomplished by using a 
HASF function on the ASCII character representation of the 
identifier name. This function generates an even number 
between zero and 126. The number is used as an index into 
the hash table by specifying an offset from the base of the 
hash table. The hash table can hold sixty-four uniquely 
determined address references to identifiers. The hash table 
entry associated with each index reference heads a linked 
list of identifiers with the same EASE function value. The 
linked list structure provides for additional identifier 
storage and therefore the number of unique identifiers is 
not limited by the sixty-four index values generated by the 
HASH function. A zero entry in the hash table indicates that 
there is no identifier with that HASH function value. In 
tracing through the linked list of identifiers the most 
recently declared variable appears at the end of the list. 
See figure [II-l] for an example of the computation of a 
hash value. See figure [II-2] for an example of the hash 
table indexing and linking of hash values. 
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HASH VALUE COMPUTATION 



HASH Function value: sun of identifier ASCII characters 

logically and with 3FH then shifted left (SEL) one hit. 



HASHBASE = 2000H 

H.F.(AB) = HASHBASE + SHL(((41H + 42E) AND 3FH),1) = 2005H 
H.F.(BA) = HASHBASE + SHL(((42H + 41H) AND 3FE).l) = 2006H 



FIGURE II-l 



HASH TABLE, SYMBOL TABLE LINKING 



HASH SYMBOL 

TABLE TABLE 







2128H 


1 1 

1 t 




1 

1 




! collision! 






2126E 


! link for I 




1 

1 


2124H 


! "ba" ! 

1 1 

1 t 



2200H 



J 2008H 

21F0H ! » > 

j 2006H 



! 2000H 



collision 
link for 

*i *» 



»-- 

21F0H 



FIGURE 1 1-2 
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1. Numeric Values 



The symbol table entry for numeric values can 
contain up to eight attributes of the variable. These 
attributes are: 1.) identifier type, 2.) length of variable 
name 3.) beginning address of variable storage, 4.) numeric 
count (number of storage locations required by the 
identifier), 5.) level number, 6.) number of digits to the 
right of the decimal point, 7.) the variable name, and 8.) a 
previous occurs pointer. The previous occurs pointer is 
appended after the identifier name only if needed. Since 
most declarations will not require the use of this pointer, 
a saving of three bytes per variable declaration is 
realized. It was felt that the increase in the total number 
of variables that could be declared in a given memory size 
outweighed the increased complexity in symbol table access 
time. Figures [ 1 1—3 ] and [II-4] illustrate, respectively, 
the following two COBOL declarations: 

01 NUM PIC 9(9) . 

02 NUM PIC 9(6) V999 OCCURS 12. 

2 . Numeric Edit 

The numeric edit symbol table entry expands on the 
numeric symbol entry and utilizes bytes eight and nine to 
hold the beginning address, in the constants area, of the 
edit field mask. This mask allowed for the insertion of the 
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following characters into the output display of a numeric 
number: fixed and floating dollar signs, credit(CR) and 
debit(DB) signs, asterisk fill, "z" character fill, and plus 
("+") and minus signs. It should be noted that an 
identifier with a numeric edit field value can not be used 
in an arithmetic statement. Figure [II-5] illustrates the 
following COBOL declaration: 

01 NUK PIC +$ZZZ ,ZZ9 .99. 



21 



NUMERIC SYMBOL TABLE ENTRY. 



BYTE SYMBOL TABLE VALUE 



0-1 


i — - — 

i collision link 

! (00 00) 


2 


j type identifier 

! (10) 

1 


3 


1 

i length of identifier 
! name (03) 


4-5 


! beginning address 
! of identifier 

! storage (04 25) 

* ^ 


6-7 


! 

j length of identifier 
! storage (09 00) 


8-9 


j not used 

1 „ _ 


10 


1 

j level entry (01) 


11 


1 ” 

j decimal count (30) 


12-13 


! 

! occurances (00) 


14-16 


{ identifier name 
j (4E 55 4D) 



01 NUM PIC 9(9) . 
FIGURE 1 1-2 
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NUMERIC SYMBOL 
AND 


TABLE ENTRY WITH DECIMAL 
OCCURS CLAUSE 



BYTE 


SYMBOL T> BLE VALUE 


0-1 i 

i 

i 

i 


collision link 
(09 2E ) 


i 

2 ! 
1 
1 


type identifier 
(10) 


3 i 

i 

i 

i _ 


length of Identifier 
name (03) 


i 

i 

4-5 ! 

i 

i 

i 


beginning address 
of identifier stor- 
age (0D 25) 


6-7 | 

i 

i 


length of identifier 
storage (09 00) 


8-9 j 


not used 


10 j 


level entry (02) 


11 i 


decimal count (03) 


12-13 ! 

i _ 


occurances (0C ) 


14-16 j 

i 

i 

i 


identifier name 
(4E 55 4D ) 


17-18 i 

i 

i 


previous occurs 
pointer 00 00 


19 ! 


dimension counter 



02 NUM PIC 9 ( 6 ) V999 OCCURS 12. 
FIGURE I 1-4 
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NUMERIC SYMBOL TABLE ENTRY WITH EDITED FIELD 



BYTE 


SYMBOL TABLE VALUE 


0-1 


colision link 
(09 2E ) 


2 


type identifier 
(80) 


u 


length of identifier 
name (03) 


4-5 


beginning address 
of identifier stor- 
age (0D 25) 


6-7 


length of identifier 
storage (09 00) 


8-9 


beginning address 
of mask storage 
(25 FE) 


10 


level entry (01) 


11 


decimal count (02) 


12-13 


occurances (00) 



14-16 i identifier name 
! (4E 55 4D ) 

01 NUM PIC +£ZZZ ,ZZ9.99. 
FIGURE I 1-5 
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3. Alpha or Alphanumeric 



The alpha and alphanumeric symbol table entries 
appear similarly in the symbol table except for their type 
fields. Six entries appear in the symbol table for these 
identifiers: 1.) identifier type, 2.) length of identifier 
name, 3.) beginning address of storage, 4.) number of 
storage locations required by the identifier, 5.) level 
entry, and 6.) identifier name. Figure [ 1 1—63 illustrates an 
alpha symbol table entry for the following identifier 
declaration : 

01 ALPHA PIC A( 8 ) . 

4. Alpha Edit 

The alpha edit symbol table entry expands on the 
alpha and alphanumeric edit types and utilizes bytes eight 
and nine to hold the beginning address of the edit field 
mask. These mask fields, which are stored in the constants 
area of the pseudo-machine, contain the characters necessary 
to edit an output so that, for example, slashes or blanks 
can be interspersed in the display output. 
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ALPHA STMBOL TABLE ENTRY 



BYTE SYMBOL TABLE VALUE 



0-1 


i collision link 

! (00 00) 

1 


2 


i 

i type identifier 
! (03) 


3 


! length of identifier 
! (05) 


4-5 


i beginning address 
! of identifier 
! storage (16 25) 


6-7 


i length of identifier 
! storage (08 00) 


£-9 


! not used 
1 


10 


1 

! level entry (01) 


11 


! not used 


12-13 


! not used 


13-17 


! identifier name 
! (41 4C 50 48 41 ) 



01 ALPHA PIC A ( 8 ) . 



EIGURE I 1-6 
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5 . Tables 



NPS !*!ICRO-COBOL supports multiply indexed tables up to a 
maximum of ten levels. The choice of ten levels was based on 
a compromise between a single level of HYPO-COBOL and 49 
levels proposed for the new 1983 ANSI COBOL standard. The 
limit of ten levels is a restriction for HYPO-COBOL and the 
nucleus level 1 constructs of ANSI-COEOL. These tables are 
established by using an OCCURS clause with the PIC clause of 
an identifier. If an identifier is specified as a table the 
number of occurances of the table are placed in byte twelve 
and thirteen of the symbol table entry for that identifier. 
The table identifier in COBOL is similar to the subscripted 
variable in other programming languages. The previous occurs 
pointer shown in FIGURE II-4 is used to indicate where 
variables are located and how many occurances exist to 
enable the compiler to generate the proper base address. For 
example, the statement, "02 NUM PIC 9(9) OCCURS 12", 
generates the symbol table entry illustrated in figure 
CII-4]. 

6 . Labels 

Labels generate the simplest of all symbol table 
entries, only four or five attributes are associated with 
the label. The variability depends on whether the label is 
declared in the source program before or after the label is 



27 



referenced by a GO or PERFORM statement. In the event that a 
label is specified before a C-0 or PERFORM statement 
references it, the symbol table would contain the following 
1.) the type associated with label, 2.) the length of the 
identifier name, 3.) the address of the first intermediate 
code instruction following the appearance of the label in 
the source program (bytes four and five), 4.) the last 
executable instruction associated with the label (bytes 
eight and nine) (This would be either the last executable 
instruction encountered before another label or the end of 
the program), and 5.) the label name. 

In the event a label is referenced by a GO or 
PERFORM statement before the label actually appears in the 
code, the symbol table entry performs a different function 
than just indicating the beginning and ending of the 
paragraph associated with the label. The same symbol table 
fields are used, however their meanings are different. The 
type is set to that of an unresolved label(0EFH). The label 
remains unresolved until the beginning and the ending 
addresses of the associated paragraph are determined. If a 
label is never resolved by the end the input file, an error 
for each unresolved label is produced as a warning to the 
user. 

When a label is referenced for the first time by a 
GO statement the symbol table is initialized with the 
following: 1.) unresolved label type (0EFH), 2.) the address 
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of the GO statement (the intermediate code would be BRN 00 
00 where the zeros indicate where the address of the label 
is to be backstuffed. See section III-D for specific 
explanation of pseudo-machine instructions), 3.) the 
remainder of the label entries would be the same except no 
entry is made for the last executable instruction associated 
with the label. If an additional reference is made to the 
label by a subsequent GO statement the following action 
would occur: 1.) the current address (bytes four and five) 
would be placed in the branch address of the GO statement, 
2.) the address of this branch statement would be placed in 
bytes four and five of the symbol table entry. This 
procedure facilitates linking together all unresolved 
references to labels so as a result when the label is 
resolved the correct branch address can easily be placed 
into the intermediate code. 

Encountering a PERFORM statement before a label is 
declared causes the following actions: 1.) Bytes four and 
five contain the address of the next byte of intermediate 
code following the PER intermediate code instruction, and 
2.) bytes eight and nine contain the address of the third 
byte following the PER instruction. If a subsequent PERFORM 
statement is encountered before the label is resolved the 
two address fields in the symbol table would be copied to 
the associated bytes following the most current PERFORM 
statement and the address of the first and third bytes 
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following the PER instruction would he copied into the 
symbol table. It should be pointed out that any number of 
PERFORM and GO statements can be specified before a label is 
resolved . 

7. Files 

The symbol table entries for files are the most 
difficult to understand. The complexity of the entries is 
due to the way files and records are declared in a 
MICRO-COEOL program. The symbol table entry for a file 
consists of the following: 1.) byte two contains the type, 
2.) byte three contains the length of the file name, 3.) 
bytes four and five contain the address in the symbol table 
of the first 01 level record associated with the file, 4.) 
bytes eight and nine contain the beginning address of the 
file control block and input/output buffer for the file, 
(this would be the actual address in the data section of the 
pseudo-machine for the beginning of the 165 bytes associated 
with the file), 5.) if the file has a key entry associated 
with it (access via RANDOM or RANDOM RELATIVE) bytes ten and 
eleven contain the symbol table address of the access key 
variable, and 6.) the rest of the entry contains the file 
name. Figure Cl 1—6] illustrates a file entry in the symbol 
table . 

8. Records 
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This entry contains seven attr 
Three are the same as all other entries 
length of name. While the other four are: 
five contain the initial storage address 
bytes six and seven contain the number 
for the record, 3.) bytes eight and nine 
table address of the file associated wi 
facilitates referencing the file when 
written), and 4.) byte ten contains the 
record . 
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FILE SYMBOL TAELE ENTRY 

SAMPLE SOURCE PROGRAM FILE DECLARATION 

INPUT-OUTPUT SECTION. 

FILE-CONTROL. 

SELECT ROSTER-FIL 

ORGANIZATION RELATIVE 
ACCESS RANDOM RELATIVE NUM 
ASSIGN CS61-FIL. 



BYTE 


SYMBOL TABLE VALUE 


0-1 


i collison link 


2 


! tyoe file 

! (03) 

_ 1 


3 


1 

! length of file 
i name (05) 

i 


4-5 


i 

! symbol table 
! address of first 
' 01 level record 
! (09 2E) 


6-7 


j not used 


8-9 


' first address of 
! FCB S. buffer 
! ( 0E 26) 


10-11 


! symbol table 
! address of key 
! (33 27) 


12-13 


! not used 


14-18 


i file name 
! (52 4F 53 54 45 52 
! 5F 46 49 4C) 



FIGURE 1 1-7 
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C. COMPILER MODULE "PART ONE” 

1 . Purpose 

The first rrodule of the compiler performs several 
functions. First, it establishes the interface between the 
compiler and: 1.) the input source file (of type "CBL”) , 2.) 
the output intermediate code file (of type "CIN"), 3.) the 

output list file (of type "LST"), and 4.) the READER module 
which reads and passes control to PART TWO of the compiler. 
Second, it scans and parses the source program statements up 
to the PROCEDURE DIVISION. Third, it generates output 
consisting of the symbol table entries (saved in memory) and 
data initialization intermediate code. A listing file is 
also created which will contain any compilation errors 
generated and a listing of the source code if the 

appropriate toggle is activated. See Appendix A for a list 
of compiler options. 

2 . Control Actions 

By executing the command COBOL <source program> 
$<compiler toggles> the object code for PART ONE of the 
compiler is loaded into memory starting at 100H (if 

necessary this can be modified for different machines) by 
the CP/M operating system. Execution of PART ONE loads the 
source program name into the input file control block 
located at 5CE. This allows the source program name to be 
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saved until actual source program compilation 
compiler toggles are loaded into the input fi 
block located at 6CH. These optional toggles are 
to initialize certain features such as code, noc 
nolist, etc. See Appendix A for a complete list o 
Next, the control program, READER, is mo 
memory just below the BDOS (see reference 
explanation of BDOS and other CP/M associated 
example, using an INTEL Corporation 62K MBS mi 
system with the CP/M operating system, the READER 
moved to high memory starting at 0D0C0E and 
through 0D0FEE. This is done for two reasons: 1.) 
the symbol table of the source program to begin 
address following the object code for PART ONE 
places READER high enough in memory so tha 
destroyed by creation of the symbol table. S 
[II-?] and [II —8] for illustrations of the PART 
organization before and after the READER routine 
The purpose of the READER routine will be expla 
next section. 
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MEMORY ORGANIZATION BEFORE READER ROUTINE MOVED 



BDOS 



Free Area 

READER Routine 
Before Move 



Part 1 of Compiler 



F000H 
Top of 



D100H 



3700H 

3600H 



100H 

000E 



Memory 



FIGURE 1 1-7 
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MEMORY ORGANIZATION AFTER READER ROUTINE MOVED 



BDOS 



READER Routine 
After Move 



Free Area 



Reserved for Part 2 



Part 1 of Compiler 



F800B 

Top of Memory 



D100H 

D000H 



3800H 

3600H 



100H 

000H 



FIGURE II— Q 
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Next, the interface between the compiler and the input 
file <source program> and the output file <in termed! ate code 
file> is established. The input file control block 
associated with the source file is initialized and the input 
file is opened. The input file name is copied to the output 
file control block (FCB) and if there is an intermediate 
code file already residing on the disk, it is erased. The 
output FCB is initialized and a file directory entry 
established for the new copy of the intermediate code file. 
A list file control block and associated buffer are created 
and opened. The list file contains any error messages 
generated by the compiler and the line being parsed at the 
time the error was discovered. The relative line number is 
also provided. With the list toggle activated the list file 
will contain the complete input file with errors and line 
numbers . 

Prior to beginning scanning and parsing actions, the 
first 128 byte record of the input file is read into the 
input buffer, located at 80H (default I/O buffer for CP/M). 
The scanner is primed with the first character of the input 
program, and scanning and parsing actions continue from this 
point in PART ONE until the PROCEDURE DIVISION of the source 
program is encountered; at this time compilation is 
suspended . 

3. Symbol Table Entries 
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Entries made in the symbol table by PART ONE will 
consist of all identifiers declared in the DATA DIVISION of 
the source program. By refering to the Symbol Table Section 
above, an explanation may be obtained regarding the various 
types of symbol table entries. 



4. Intermediate Code Generation 

Pseudo-instructions are written to the intermediate code 
file for several different reasons while PART ONE is 
scanning and parsing the source program. The first 
intermediate code generated occurs when the INPUT-OUTPUT 
SECTION of a source program is nonempty. Within the PILE 
CONTROL PARAGRAPH of this section, instructions are 

generated to initialize the FCB for the file name associated 
with the SELECT statement. The name associated with the 
ASSIGN statement is placed in the FCB and is used in 
referencing the file on the disk. 

Two other instances of intermediate code generation 
occur in the WORKING STORAGE SECTION of a source program. 
Anytime a record or elementary identifier entry has an 
edited PICTURE CLAUSE, code to initialize the storage 
beginning at the address specified in the formatted mask 
attribute of the symbol table entry will be written to the 
intermediate code file. When a record or elementary 
identifier entry has an associated numeric or nornumeric 



38 



VALUE CLAUSE, code to initialize the storage beginning at 
the address specified in the value location attribute of the 
symbol table entry will be written to the intermediate code 
file. 

The final pseudo-instruction written to the intermediate 
code file is the SCD instruction. This occurs when the 
parser parses the word PROCEDURE in the source program? 
control is then passed to PART TWO and compilation 
continues. 

5 . Parser Actions 

The actions corresponding to each parse step are 
explained below. In each case, the grammar rule that is 
being applied is given, and an explanation of what program 
actions take place for that s'tep has been included. In 
describing the actions taken for each parse step there has 
been no attempt to describe how the symbol table is 
constructed, what pseudo-instructions are generated or how 
the values are preserved on the stack. The intent of this 
section is to describe what information needs to be retained 
and at what point in the parse it can be determined. Where 
no action is required for a given statement, or where the 
only action is to save the contents of the top of the stack, 
no explanation is given. Questions regarding the actual 
manipulation of information should be resolved by consulting 
the program listings. 
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1 

2 

3 

4 

5 

6 

7 

8 

9 

10 

11 

12 

13 

14 

15 

16 

17 

18 

19 



<program> ::= <id-div> <e-div> <d-div> PROCEDURE 
Reading the word PROCEDURE terminates the first 



part of the compiler. 

<id-div> ::= IDENTIFICATION DIVISION. PROGRAM-ID. 

<comment> . <id-list> 

<id-list> ::= <auth> <ins> <date> <sec> 

<auth> ::= AUTHOR . <comment> . 

! <empty> 

<ins> ::= INSTALLATION . <comment> . 

! <empty> 

<date> ::= DATE-WRITTEN . <comment> . 

! <empty> 

<sec> ::= SECURITY . <comment> . 

! <empty> 

<comment> ::= <input> 

i <comment> <input> 

<e-div> : := ENVIRONMENT DIVISION . CONFIGURATION 
SECTION. <src-obj> <i-o> 
j <empty> 

<src-obj> ::= SOURCE-COMPUTER . <comment> <debug> . 

OBJECT-COMPUTER . <comment> . 

<debug> ::= DEBUGGING MODE 

Set a scanner toggle so that debug lines will be 
read . 

! <empty> 

<i-o> ::= INPUT-OUTPUT SECTION . FILE-CONTROL . 
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<f ile-control-li st> <ic> 

20 i <empty> 

21 <f i le-contro l-lis t> <f ile-control-entry> 

22 ! <f ile-control-lis t> 

<f i le-contro 1-ent ry> 

23 <f i le-control-entry> ::= SELECT <id> <a ttribute-li st> . 

At this point all of the information about the file 
has been collected and the type of the file can be 
determined. File attributes are checked for 
compatibility and entered in the symbol table. 
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<attribute-list> 


::= <one attrib> 


25. 




! <attribute-list> <one attrib> 


26 


<one-attrib> ::= 


ORGANIZATION <org-type> 


27 


1 

1 


ACCESS <acc-type> <rslative> 


28 


1 

1 


ASSIGN <input> 



A file control block is built for the file using the 
INT operator. 

29 <org-type> : := SEQUENTIAL 

No information needs to be stored since the default 
file organization is sequential. 

30 | RELATIVE 

The relative attribute is saved for production 23. 

31 | INDEXED 

The indexed attribute is not implemented. 

27 <acc-type> : := SEQUENTIAL 
This is the default. 
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28 



i 

i 



RANDOM 



The random access mode is saved for production 19. 
29 <relative> : RELATIVE <id> 

The pointer to the identifier will be retained by 
the current symbol pointer, so this production only 
saves a flag on the value stack indicating that the 
production did occur. 

35 i <empty> 

36 <ic> ::= I-O-CONTROL . <same-list> 

3? ! <empty> 

38 <same-list> : := <same-element> 

39 ! <same-list> <same-element> 

40 <same-elemen t> ::= SAME <id-string> . 

41 <id-string> ::= <id> 

42 i <id-string> <id> 

43 <d-div> ::= DATA DIVISION . <f i le-sec ti on> <work> 

<1 ink> 

44 <f ile-sec ti on> ::= FILE SECTION . <file-list> 

A flag needs to be set to indicate completion of 
the file section, so that the appropriate routine 
will be called when parsing level entries in the 
WORKING STORAGE SECTION. 

45 | <empty> 

The flag, indicated in production 44, is set. 

46 <file-list> ::= <f ile-element> 

47 | <f ile-li st> <f ile-element> 
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48 <files> : := FD <id> <f ile-cont rol> . 

<reco rd~d.es cripti or> 

This statement indicates the end of a record 
description, if there was an implied redefinition 
of the record, then the level stack (ID$STACK) 
must he reduced. The length of the first record 
description and its address can now be loaded 
into the symbol table for the file name. 

49 <fi le~control> ::= <file-list> 

The address of the symbol table entry for the 
record describing the file name is entered into an 
attribute of the file name symbol table entry, 
while the address of the file name's symbol table 
entry is entered into an attribute of the same 
record . 

50 ! <empty> 

Same as 49 above. 

51 <file-list> ::= <file-element> 

52 | <f ile-li st> <f ile-element> 

53 <fi le~element> ::= BLOCK <integer> RECORDS 

54 j RECORD <rec~count> 

The record length is saved for comparison with 
the calculated length from the picture clauses. 
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! LABEL 


RECORDS STANDARD 


56 


! LABEL 


RECORDS OMITTED 


57 


i VALUE 


OF <id-s tring> 
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58 <rec-count> ::= <integer> 

59 I <integer> TO <integer> 

The TO option is the only indication that the file 
will he variable length. The maximum length must be 
saved . 

60 <work> ::= WORKING-STORAGE SECTION . <rec ord-descripti on> 

If the level stack (ID$STACK) contains a record 
identifier with a level number greater than one, 
then the stack must be reduced. The reduction 
depends on whether the identifier on the top of 
the stack is a redefinition of the item beneath 
it or not. The primary action is to assign the 
proper amount of storage to the last record in 
the WORKING STORAGE SECTION. 

61 <empty> 

62 <link> ::= LINKAGE SECTION . <record-desc ripti on> 

63 ' <empty> 

64 <record-description> ::= <level-entry> 

65 i <record-description> <level-ent ry > 

66 <level-entry> ::= <integer> <data-id> <redefines> 

<data-type> . 

The symbol table address for the level entry 
identifier is loaded into the level stack 
(ID$STACK). The level stack keeps track of the 
nesting of field definitions (elementary items) 
in a record in the FILE and WORKING STORAGE 
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SECTIONS. At this point there may he no infor- 
mation about the length of the item being defined 
and its attributes may depend entirely upon its 
constituent fields. Within the FILE SECTION, 
multiple record descriptions for a file are 
assumed to be redefinitions of the first record 
description. In the WORKING STORAGE SECTION, if 
there is a VALUE CLAUSE, the stack level to which 
it applies is saved in PENDING$LITERAL , the level 
entry number is saved in VALUE$LEVEL and a flag, 
VALUE$FLAG, is set. 

67 <data-id> ::= <id> 

68 ! FILLER 

An entry is built in the symbol table to record 
information about this record field. It cannot be 
used explicitly in a program because it has no name, 
but its attributes will need to be stored as part of 
the total record. 

69 <redef ines> ::= REDEFINES <id> 

The redefines option gives new attributes to a 
previously defined record area. The symbol table 
pointer to the area being redefined is saved in an 
attribute of the redefining identifier's symbol table 
entry, so that Information can be transferred to the 
area by either identifier. In addition to the inform- 
ation saved relative to the redefinition, it is nec- 
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essary to check to see if the current identifier's 
level number is less than or equal to the level number 
of the identifier currently on the top of the level 
stack. If this is true, then all information for the 
item on top of the stack has been saved and the stack 
can be reduced. If the current identifier is a redef- 
inition of another identifier, the stack entry for the 
record being redefined is not removed until the first 
non-redefinition of a current identifier at the same 
level . 

70 i <empty> 

As in production 64, the stack (IP$STACK) is checked 
to determine if the current level number Indicates a 
reduction of the level stack is necessary. In add- 
ition, special action needs to be taken if the new 
level is 01. If an 01 level is encountered at this 
production prior to production 39 or 40 (the end of 
the file area), it is an implied redefinition of the 
previous 01 level record. In the WORKING STORAGE 
SECTION, it indicates the start of a new record. 



71 


<data-type> ::= 


<prop-li st> 


72 


i 

i 


<empty> 


73 


<prop-list> ::= 


<data-element> 


74 


1 

1 


<prop-list> <data-element> 


75 


<data-element> 


::= PIC <input> 



The <input> at this point is the character string 
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that defines the record field. It is analyzed and the 
necessary extracted information is stored in the 
symbol table. 

76 ! USAGE COMP 

The field is defined as a binary field? however, 

COMP has not been implemented, therefore, if 
there is an associated VALUE CLAUSE, the value is 
entered into the associated identifier's value 
storage location in display format. 

77 ! USAGE COMP-3 

The field is defined as a packed Binary Coded Decimal 
field. 

78 ! USAGE COMPUTATIONAL 

Optional form of USAGE COMP. 

79 I USAGE DISPLAY 

The DISPLAY format is the default, and thus no 
special action occurs. 

80 | SIGN LEADING <separate> 

This production indicates the presence of a sign in 
a numeric field. The sign will be in a leading 
position. If the <separate> indicator is true, 
then the length will be one longer than the PICTURE 
CLAUSE, and the type will be changed to signed 
numeric leading and separate. 

81 | SIGN TRAILING <separate> 

The same information required by production 73 must 
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be recorded, but in this case the sign is trailing 
rather than leading. 

82 , ! OCCURS <integer> INDEXED <id> 

83 ! OCCURS <integer> 

The type must be set to indicate multiple 
occurrences and the number of occurrences saved 
for computing the space defined by this field. 

84 SYNC <di recti on> 

Syncronization with a natural boundary is not 
required by this machine. 

85 ! VALUE <li teral> 

The field being defined will be assigned an initial 
value determined by the value of the literal through 
the use of an INT operator. This is only valid in 
the WORKING-STORAGE SECTION. Note that numeric and 
signed numeric PICTURE CLAUSES will have a numeric 

— no quotes delimiting — VALUE CLAUSE, while 
alphanumeric and alpha types will have a nonnumeric 

— literal delimited with quotes — VALUE CLAUSE. 
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<direction> 


= LEFT 
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i RIGHT 


38 




i <empty> 


89 


<separate> : := 


SEPARATE 




The separate 


sign indicator is set. 


90 


1 

1 


<empty> 



91 <literal> ::= <input> 
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The input string is checked to see if it is a valid 
numeric literal, and if valid, it is stored to be 
used in a value assignment. 

92 ! <lit> 

This literal is a quoted string. 

93 ! ZERO 

As the case of all literals, the fact that there 
is a pending literal needs to he saved. In this 
case and the three following cases, an indicator 
of which literal constant is being saved is 
all that is required. The literal value can be 
reconstructed later. 
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! SPACE 






95 


i QUOTE 






96 


<integer> ::= <input> 








The input string is converted to an 


integer value 




for later internal use. 






97 


<id> : := <input> 








The input string is the name of an 


iden tifi er 


and 




is checked aginst the symbol table. 


If it is 


in the 




symbol table, then a pointer to the 


entry is 


saved . 




If it is not in the symbol table. 


then it is 






entered and the address of the entry is saved. 




D. 


INTEREACE ACTIONS 
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of the 



When compilation is suspended in PART ONE 
compiler certain key variables are saved for use in PART 
TWO. These variables are declared sequentially in PART ONE 
and are therefore located in contiguous memory in the 
variable area of PART ONE. These variables consist of 
debugging toggles set when invoking the compiler, i.e. 
sequence or token numbers, a pointer to the next available 
address in the symbol table, a pointer to the next character 
in the input source file, the output and list file control 
blocks, the output and list buffers, the error counter, the 
next address in the intermediate code area, the next address 
in the constants area, ana the base address of the symbol 
table. These key variables, consisting of 353 bytes, are 
copied to the 353 bytes immediately below the READER routine 
to insure they are not destroyed when PART TWO of the 
compiler is brought into memory. Since the memory area 
required for PART ONE is larger than that required by PART 
TWO the symbol table does not need to be relocated. Since 
the symbol table is not altered when PART TWO of the 
compiler is brought into memory only the base address of the 
symbol table and the last address of the symbol table need 



be saved to 


insure that 


access to the symbol table 


can 


be 


continued 


in PART 


TWO. 


See Pigure [11-10] 


for 


an 


illustration 


of the memory 


organization when control 


is 


transf ered 


from PART 


ONE 


to READER. The READER 


routine 



causes PART TWO of the compiler to be brought into memory 



50 



starting at 100H and then transfers control to PART TWO of 
the Compiler. 

E. COMPILER MODULE "PART TWO" 

1 . Purpose 

The second part of the compiler scans and parses the 
MICRO-COBOL source statements starting with the PROCEDURE 
DIVISION and generates the necessary intermediate code. 

2 . Control Actions 

The first action after control is transfered to PART TWO 
from the READER routine is to copy the 353 bytes of 
information saved from PART ONE into associated variables in 
PART TWO. After these variables are initialized all 

references to files, symbol table entries, etc. can be made 
in PART TWO and compilation can continue. See Eigure [II —1 1 ] 
for an illustration of the memory organization at the time 
PART TWO begins compilation. 

3. Symbol Table Entries 

Entries made in the symbol table by PART TWO will be 
those for paragraph labels encountered within the PROCEDURE 
DIVISION of the source program. 

4. Intermediate Code Generation 
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For an explanation of the 
generated by PART TWO refer to 
and the parser actions below, 
on pseudo-instructions refer t 



pseudo-instructions that are 
the compiler program listings 
Also, for general information 
o section III-D. 
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MEMORY ORGANIZATION WHEN CONTROL IS TRANSFERED TO READER 



— > 



-« 
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Variable Area 
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000H 



FIGURE 11-10 
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MEMORY ORGANIZATION AFTER PART TWO IS COPIED INTO MEMORY 
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FIGURE 11-11 
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5. Parser Actions 



The actions corresponding to each parse step in PART TWO 
are explained below. In each case, the grammar action that 
is being applied is given, and an explanation of what 
program actions take place for that step has been included. 
In describing the actions taken for each parse step there 
has been no attempt to describe how the symbol table entries 
are made, what pseudo instructions are generated or how the 
values are preserved on the stack. The intent of this 
section is to describe what information needs to be retained 
and at what point in the parse it can be determined. Where 
no action is required for a given statement, or where the 
only action is to save the contents of the top of the stack, 
no explanation is given. 

1 <p-div> ::= PROCEDURE DIVISION <using> . 

<proc-body> EOF 

This production indicates termination of the 
compilation. If the program has sections, then 
it will be necessary to terminate the last section 
with a RET 0 instruction. The code will be ended 
by the output of a TER operation. 

2 <using> USING <id-string> 

If the reserved word CALL is on the procedure stack then 
the PAR operator is produced followed by the addresses 
of the parameters that will be passed from the calling 
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program. If the reserved, words PROCECEDURE DIVISION are 
on the procedure stack then the identifier stack contains 
the formal parameters that will he used for that procedure. 
These variables are given sequential address locations 
starting at 0DH so that the addresses may be resolved at run 
time by getting the actual parameter address off the call 
stack. 

PAR <number of parameters> <parameter #1 address> ... 

3 i <empty> 

4 <id-string> : := <id> 

The identifier stack is cleared and the symbol 
table address of the identifier is loaded into 
the first stack location. 

5 i <id-string> <id> 

The identifier stack is incremented and the symbol 
table pointer stacked. 

6 <proc-body> : := <paragraph> 

7 ! <proc-body> <paragraph> 

8 <paragraph> : := <id> . 

9 i <id> . <sentence-list> 

The starting and ending address of the paragraph 
are entered into the symbol table. A return is 
emitted as the last instruction in the paragraph 
(RET 0). When the label is resolved, it may be 
necessary to produce a BST operation to resolve 
previous references to the label. 
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10 

11 

12 

13 

14 

15 

16 

1 ? 

18 

19 

20 

21 



! <id> SECTION . 

The starting address for the section is saved. If 
it is not the first, then the previous 
section ending address is loaded and a return 
(RET 0) is output. As in production 9, a BST' may 
be produced. 

<sentence-list> ::= <sentence> . 

i <sentence-li st> <sentence> . 
<sentence> : := <imperative> 

! <condi ti onal> 
i ENTER <id> <opt-id> 

This construct is not implemented. An ENTER allows 
statements from another language to inserted in the 
source code. 

<imperative> ACCEPT <subid> 

ACC <address> <length> 

! <arithmetic> 

! CALL <call-lit> <using> 

The SBR operator is produced. 

SBR Subroutine name> 

i CLOSE <close-lst> 

CLS <file control block address> 

! <file-act> 

! DISPLAY <display-lst> 

The display operator is produced for the first 
literal or identifier. 
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DIS <address> <length> <flag> 

22 ! DISPLAY <di splay-lst> WITH NO 

ADVANCING 

The DISPLAY WITH NO ADVANCING option is not implemented. 

23 ! EXIT <program-id> 

RET 0 

24 ! GO <id> 

BRN <address> 

25 ! GO <id-string> DEPENDING <id> 

GDP is output, followed by a number of parameters: 
<the number of entries in the identifier star’d 
<the length of the depending identified <the 
address of the depending identified <the address 
of each Identifier in the stacd. 

26 ! MOVE <11 t/id> TO <subid> 

The types of the two fields determine the move that 
is generated. Numeric moves go through register two 
using a load and a store. Non-numeric moves depend 
upon the resultant field and may be either MOV, MED or 
MNE. Since all of these instructions have long 
parameter lists, they have not been listed in 
detail. 

27 ! OPEN <act-lst> 

28 ! PERFORM <id> <thru> <finish> 

The PER operation is generated followed by the 
<branch address> <the address of the return 
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statement to be set> and <the next instruction 



address> . 



29 



STOP <terminate> 



If there is a terminate message, then STL is 



produced followed by <message address> <message 



length>. Otherwise STP is emitted. 



30 <close-lst> ::= <id> 
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! <close-lst> <id> 



Multiple close option is not implemented. 



32 <di splay-ls t> <lit/id> 



33 



! <di splay-ls t> <lit/id> 



Multiple display option is not implemented. 

34 <act-lst> ::= <type-acti on> <open-lst> 

This produces either OPN , OP1, or 0P2 depending 
upon the <type-acti on> . Each of these is followed 
by file control bloc* address. 

35 ! <act-lst> <type-action> <open-lst> 

36 <open-lst> : := <id> 

37 { <open-lst> <id> 

Multiple open option is not implemented. 

38 <finish> <l/id> TIMES 

This produces the code to perform a paragraph <l/id> TIMES. 

39 ! <stopcondi tion> 

40 ! <varying> <iteration> <s topcondi ti on> 

41 i <empty> 

42 <stopcondit ion> ::= UNTIL <condition> 
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43 <varying> ::= VARYING <subid> 

44 <iteration> : := <from> <by> 

45 <f rom> FROM <l/id> 

The counter is initialized to <l/id>. 

46 <by> ::= BY <l/id> 

The counter is incremented BY <l/id>. 

4? <conditional> ::= <arithmetic> <size-error> <imperative> 
A BST operator is output to complete the branch around 
the imperative from production 117. 

48 ! <file-act> <invalid> <imperative> 

A BST operator is output to complete the branch from 
production 116. 



49 ! <read-id> <special> <imperative> 

A BST is produced to complete the branch around the 
<imperati ve>. 



50 i <if-nonterminal> <condition> 

<if-lst> <el se> <if-lst> END-IF 
NEG will be emitted unless <condition> is a 
"NOT <cond-type>” , in which case the two negatives 
will cancel each other. Two BST operators are required. 
The first fills in the branch to the ELSE action. The 
second completes the branch around the <if-lst> 
which follows ELSE. 
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j <if-nonterminal> <condition> 
<if-l st> END-IF 



52 <if-lst> ::= <stmt-lst> 
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53 



I 



NEXT SENTENCE 



A branch operator is produced to branch to the end of 
the current sentence. 

54 <else> ::= ELSE 

55 <Arithmetic> ::= ADD <add-lst> TO <subid> <round> 

The existence of multiple load and store instructions 
make it difficult to indicate exactly what code will 
be generated for any of the arithmetic instructions. 
The type of load and store will depend on the nature 
of the number involved, and in each case the standard 
parameters will be produced. This parse step will in- 
volve the following actions: first, a load will be 
emitted for the first number into register zero. If 
there is a second number, then a load into register 
one will be produced for it, followed by an ADD ar.d a 
STI. Next a load into register one will be generated 
for the result number. Then an ADD instruction will 
be emitted. Finally, if the round indicator is set, a 
RND operator will be produced prior to the store. 

56 | ADD <add-lst> GIVING <subid> <round> 

The ADD GIVING option is not implemented. 

57 | DIVIDE <l/id> INTO <l/id> <round> 

The first number is loaded into register zero. The 
second operand is loaded into register one. A DIV 
operator is generated, followed by a RND operator 
prior to the store, if required. 
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58 

59 

60 

61 

62 

63 

64 

65 

66 

67 

6e 

69 



I DIVIDE <l/id> BY <l/id> GIVING 
<subid> <round> 

The DIVIDE GIVING option is not implemented. 

! DIVIDE <l/id> INTO <l/id> GIVING 
<suMd> <round> 

| MULTIPLY <l/id> BY <subid> <round> 

The multiply is the same as the divide except that a 
MUL operator is generated. 

! MULTIPLY <l/id> BY <l/id> GIVING 
<subid> <round> 

! SUBTRACT <suh-lst> FROM <subid> 

<round> 

Subtaction generates the same code as the ADD except 
that a SUE is produced in place of the ADD. 

| SUBTRACT <sub-lst> GIVING <subid> 
<round> 

The SUBTRACT GIVING option is not implemented. 

! COMPUTE <subid> = <arith-exp> 

The COMPUTE verb is not implemented. 

<add-lst> : := <l/id> 

! <add-lst> <l/id> 

Multiple ADD option is not implemented. 

<sub-lst> ::= <l/id> 

i <sub-lst> <l/id> 

Multiple SUBTRACT option is not implemented. 
<arith-exp> ::= <term> 
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70 

71 

72 

73 

74 

75 

76 

77 

78 

79 

80 

81 

32 

83 

84 

85 

86 



Productions 69 through 80 are required for the COMPUTE 
verb and are not impl emented . 

i <arith-exp> + <term> 

! <arith-exp> - <term> 

+ <term> 
i - < t e rm> 

<term> ::= <primary> 

j <term> * <primary> 

! <term> / <primary> 

<primary> ::= <prim-elem> 

' <primary> ** <prim-elem> 

<prim-elem> <l/id> 

i ( <arith-exp> ) 

<f i le-ac t> ::= DELETE <id> 

Either a DLS or a DLR will he produced along with the 
required parameters. 

REWRITE <id> 

Either a RVS or a RWR is emitted, followed by parame- 
ters . 

i WRITE <id> <special-act> 

There are four possible write instructions: WTE, WVL, 
WRS , and WRR . 

<condition> ::= <bterm> 

The logical OR and AND operators are not implemented, 
j <condition> OR <bterm> 

<bterm> : := <bprim> 
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87 



i 

i 



<bterm> AND <bprim> 



88 <bprim> : := <lit/id> 

89 ! <lit> <not> <cond-type> 

One of the compare instructions is produced. They are 
CAL, CNS, CNU, RGT , RLT , REQ, SGT, SLT , and SEQ. 

Two load instructions and a SOB will also be generated 
if one of the register comparisons is required. 



90 


! ( 


<bterm> ) 


91 


<cond-type> :: 


= NUMERIC 


92 




| ALPHABETIC 


93 




i <compare> <llt/id> 


94 


<not> : := NOT 





95 

96 

97 

98 

99 



NEG is emitted unless the NOT is part of an IE 
statement in which case the NEG in the IE 
statement is cancelled. 

! <empty> 

<compare> ::= GREATER 
! LESS 
! EQUAL 
! > 



Productions 99-101 are not implemented. 

100 i < 

101 ! = 

102 <R0UND> ::= ROUNDED 

103 ! <empty> 

104 <terminate> ::= <literal> 
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105 ! RUN 

106 <special> : := <invalid> 

10? ! END 



An EOR operator is emitted followed by a z 
zero acts as a filler in the code and wi 
stuffed with a branch address. In this prod 
and several of the following, there is a fo 
branch on a false condition past an imperat 
For an example of the resolution, examine p 
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<opt-id> : 


:= <subid> 


109 




i <empty> 


110 


<stmt-lst> 


: := <imperati ve> 


111 




j <stmt-lst> <imperative> 


112 




! <condi ti onal > 


113 




! <stmt-lst> <conditional> 


114 


<thru> : := 


THRU <id> 


115 


j 


<empty> 


116 


<invalld> 


: := INVALID 



ero . The 
11 be back- 
uction 
rward 

ive action, 
roduction 48. 



INV 0 



117 <size-error> ::= SIZE ERROR 

SER 0 

118 <special-act> ::= <when> ADVANCING <how-many> 

119 ! <empty> 

120 <when> : := BEFORE 

121 ! AFTER 

122 <how-many> : := <integer> 
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123 



PAGE 



124 <type-action> ::= INPUT 



125 



126 



i OUTPUT 

! i-o 



12? <subid> ::= <subscript> 
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! <id> 



129 <integer> : := <input> 

The value of the input string is saved as an internal 
number . 

130 <id> ::= <input> 

The identifier is checked against the symbol table, if 
it is not present, it is entered as an unresolved 
label. 

131 <l/id> : := <input> 

The input value may be a numeric literal. If so, it 
is placed in the constant area with an INT operator. 
If it is not a numeric literal, then it must be an 
identifier, and it is located in the symbol table. 

132 ! <subscript> 

133 i ZERO 

134 <subscript> ::= <id> ( <subscript-lst> ) 

A SCR operator is produced with the base address cf a 
variable defined with an OCCURS clause. Multiple 
subscripting has not been implemented. 

135 <subscript-lst> ::= <input> 

136 j <subscript-lst> , <input> 
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137 

138 

139 

140 

141 

142 

143 

144 

145 

146 

147 

148 

149 



<call-lit> : := <1 1 1 > 

The name of the module to be called is saved for use 
in production 18. 

<nn-lit> : := <lit> 

The literal string is placed into the constant area 
using an INT operator. 

! SPACE 
! QUOTE 

<literal> : := <nn-lit> 
i <input> 

The input value must be a numeric literal to be valid 
and is loaded into the constant area using an INT 
operator . 

i ZERO 

<li t/id> : := <l/id> 

! <nn-lit> 

<program-id> ::= <id> 

! <empty> 

<reai-id> READ <id> 

There are four read operations: RDF, RVL, RES, and 

RRR . 

<if-nonterminal> : :=IF 
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III. NPS MICRO-COBOL INTERPRETER 



A. GENERAL DESCRIPTION 



The following sections describe the NPS MICRO-COBOL 
pseudo-machine in terms of the implementation, memory- 
organization, interface actions and interpreter 
instructions. The pseudo-machine, which is constructed in 
the transient program area of CP/M, is the target machine 
for the compiler and is implemented through a programmed 
interpreter. The interpreter decodes each operation and 
either calls subroutines to perform the required actions or 
acts directly on the run time environment to control the 
actions of the interpreter. All communications between 
instructions is done through common areas in the program 
where information can be stored for later use. See figure 
Cl 1 1 — 1] for an illustration of the pseudo-machine 
organization . 

The machine contains a program counter and multiple 
parameter operations which contain all the information 
required to perform one complete action required by the 
language. Three eighteen digit, double length registers are 
used for arithmetic operations, along with a subscript stack 
used to compute subscript locations, a parameter stack to 
resolve the address of actual parameters and a set of flags 
which are used to pass branching information from one 
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instruction to another 



Addresses in the pseudo-machine are represented by 16 
bit values. Any memory address greater than 20 hexidecimal 
is valid. Addresses less than 20 hexidecimal will be 
interpreted as having special significance. For example 
addresses one through eight are reserved for subscript stack 
references. All other addresses, in the machine are absolute 
addresses 

The registers allow manipulation of signed numbers up to 
eighteen digits in length. Included in their representation 
is a sign indicator and the position of the assumed decimal 
point for the currently loaded number. Numbers are 
represented in standard COBOL "Display" or "Binary Coded 
Decimal” (C0tfP-3 or BCD) format. These numbers may have 
separate signs indicated by "+” and or may have a "zone" 
indicator, denoting a negative sign, in the most significant 
byte of a number's storage location. Before operations occur 
on any number, it is converted to a packed decimal format 
and entered into one of the pseudo-machine registers. 



B. MEMO?! ORGANIZATION 

The memory of the pseudo-machine is divided into three 
major areas: 1.) the data area is established by the DATA 
DIVISION statements of the source program, 2.) the constants 
area which is established by both the DATA and PROCEDURE 
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DIVISIONS of the source program, and 3.) the 
is established by the PROCEDURE DIVISION. 

The data area is the lowest area in the 
This area contains the storage for identifier 
the DATA DIVISION. Additionally, the data ar 
File Control Block (FCB) and the buffer spac 
for all files declared in the source program. 

Immediately following the data area is 
This contiguous area of storage contains all 
generated. The constants area is located in h 
the pseudo-machine. This area contains all e 
as well as all numeric and non-numeric li 
[ 1 1 1 —1 3 illustrates the memory organ! 

pseudo-machine. 
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PSEUDO-MACHINE ORGANIZATION 



Ease of BDOS 



Constants Area 



Possible Free 

Memory- 



Intermediate 
Code Area 



Data Area 



Interpreter Code 



0F800E Top of Memory 



0D100H 



SCD 



3500H 



0100H 

0000E 



FIGURE III-l 
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C. INTERPRETER INTERFACE 



The interpreter consists of two interface routines and 
the main interpreter program. To execute the interpreter the 
command EXEC <filename>, (where file type is CIN), is typed 
at the terminal. This action causes the two interface 
routines, BUILD and INTRDR, to be brought into memory. See 
figure [III-2] which illustrates the memory organization 
immediately after BUILD and INTRDR have been copied into 
memory . 

The BUILD routine reads in the intermediate code, 
initializes all memory locations requiring initialization, 
and resolves all unresolved address references. Ir. addition 
the BUILD routine loads subroutines into memory. If a SER 
instruction is encountered during execution of EUILD, the 
SUB$FLAG is set as an indicator that subroutines will have 
to be loaded. The name of the subroutine is saved and when 
the TER instruction is encountered a check of the SUB$FLAG 
is made and if set each subroutine is loaded into memeory. A 
table similar to the compiler's symbol table is used to 
maintain the names, location, and status (loaded or 
unloaded) of each subroutine. Until a subprogram is loaded 
the actual branch address is not known. The same mechanism 
used for resolving forward branches to paragraphs is used to 
backstuff all previous references to the called procedure. 
Once loaded the address is known so no futher action is 
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required. See figure [III —5] for an illustration of a 
subroutine table entry. 

The INTRDR routine reads the interpreter program into 
memory and transfers control to it. 

The intermediate code instructions fall into two 
categories: 1.) instructions used by BUILD to establish the 
run time environment and, 2.) instructions to be executed by 
the interpreter. The following four instructions are 
generated in the compiler for use by the BUILD routine? SCD, 
INT, BST , and TER. 

The SCD (start code) instruction is the last instruction 
generated by PART ONE and indicates where the first 
executable instruction for the intermediate code is to be 
loaded. This corresponds to the address immediately 
following the data area in the pseudo-machine. See Figure 
[III-l] which illustrates the relative location of the 
address that is associated with the SCD instruction. Figure 
[1 1 1-4] illustrates the memory organization of the 
pseudo-machine when subroutines are used. 
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MEMORY ORGANIZATION AFTER BUILD AND I NTH DR 



HAVE BEEN LOADED INTO MEMORY 



Base of BDOS 



Free Memory 
INTRrR ROUTINE 



BUILD ROUTINE 



0F800H 

Top of Memory 



0D100H 



1D00H 

1C80H 

100H 

080H 

00eH 



FIGURE III —2 
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The 


INT 


(initialize) instruction causes 


the 


BUILD 


routine 


to 


initialize the data area with 


the 


values 



associated with those identifiers in the TATA DIVISION of 
the source program that had VALUE CLAUSES. In addition, the 
INT instruction causes the BUILD routine to initialize the 
constants area with ell the edit masks for those identifiers 
of the numeric and alphanumeric edit type, and all literals 
encountered in the PROCEDURE DIVISION of the source program. 



The BST 


(backstuff) instruction resolves all 


un 


resolved 


references , 


i . e . 


branches to labels defined 


af 


ter 


the 


respective 


PERFORM 


or GO statement was encountered 


in 


the 



source program. 

The TER (terminate) instruction is the last instruction 
generated by PART TWO of the compiler and indicates the end 
of the intermediate code file. Upon encountering a TER 



instructio 


n in 


the intermediate 


code 


the 


EUILD 


rout 


i ne 


inserts a 


STP 


instruction 


i n 


its 


place . 


The 


STP ins 


t ruct 


i on 


will cause 


the 


interpreter 


to 


terminate 


int 


erpreta 


t i on 


of 



the program when encountered. 

All other code generated by the compiler is copied into 
the code area of the pseudo-machine by the BUILD routine. 
See Figure [III-31 for an illustration of the memory 
organization at this point in the initialization routine. 
The final action taken by the BUILD routine is to move the 
INTRDR routine into the input buffer at 80H and transfer 
control to it. This frees the area from 100H to the base of 
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the data area for the interpreter. 
The INTRDR routine reads the 
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MEMORY ORGANIZATION AFTER INTERMEDIATE CODE IS 
LOADED INTO MEMORY AND BEFORE THE INTERPRETER 

IS LOADED 



Base of BDOS 
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FIGURE 1 1 1-3 
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MEMORY ORGANIZATION AFTER THE INTERMEDIATE CODE 
SUBROUTINES AND TEE INTERPRETER ARE LOADED. 



Base of BDOS 


Constants Area 




for Main Program 


Constants Area 
for Subprogram 


1 


Constants Area 
for Subprogram 


2 



Constants Area 
for Subprogram N 

Possible Free Area 



Code and Data Area 
for Subprogram N 



Code and Data Area 
for Subprogram 2 



Code and Data Area 
for Subprogram 1 

Code and Data Area 
for Main Program 



Interpreter Code 



Input Buffer 
Input FCB 
CP/M O/S Entry 



0F800H Top of Memory 
0D00H 
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0000H 



FIGURE I I 1-4 
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SUBPROGRAM TABLE ENTRY 



BYTE SUBPROGRAM TABLE ENTRY 



0-1 


- 1 
i 

! collision link 
| (00 00 ) 


2-3 


| subprogram address 

I (48 52) 

- 1 


4-5 


1 

! lov$offset 
| (00 00 ) 


5-6 


! high$of f set 
| (00 00 ) 


7-14 


! file name 

} (49 43 31 35 32 20 20 20) 

- I 


15 


! load$flag 

I ( 00 ) 

_ 1 ^ ^ 

1 



CALL 'IC152' 



FIGURE 1 1 1-5 
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D. PSEUDO-MACHINE INSTRUCTIONS 



This section briefly covers the pseudo-machine 
instructions used in the interpreter, their format, and the 
actions which they accomplish. 

1 . Forma t 

All of the interpreter instructions consist of an 
instruction number followed by a list of parameters. The 
following sections describe the instructions, list the re- 
quired parameters, and describe the actions taken by the 
machine in executing each instruction. In each case, parame- 
ters are denoted informally by the parameter name enclosed 
in brackets. The BPN branching instruction, for example, 
uses the single parameter <branch address> which is the tar- 
get of the unconditional branch. 

As each instruction number is fetched from memory, 
the program counter is incremented by one. The program 
counter is then either incremented to the next instruction 
number, or a branch is taken. 

The three eighteen digit registers which are used by 
the instructions covered in the following sections are re- 
ferred to as registers zero, one, and two. 



2. Arithmetic Operations 



upon 



There are five arithmetic 
the three registers. In 



instructions which act 
all cases, the result is 
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Placed in register two. Operations are 
the input values during the process 
therefore, a number loaded into a regis 
for a subsequent operation. 

ADD: (addition). Sum the conten 
and register one. 

Parameters: no parameters are required 

SUB: (subtract). Subtract regis 



allowed to destroy 
of creating a result, 
ter is not available 

ts of register zero 



ter zero from register 



one. 

Parameters: no parameters are required. 

MUI: (multiply). Multiply register zero by register 



one. 

Parameters: no parameters are required. 

DIV: (divide). Divide register one by the value in 
register zero. The remainder is not retained. 

Parameters: no parameters are required 

RND:(round). Round register two to the last signifi- 
cant decimal place. 

Parameters: no parameters are required. 

3 . Branchi ng 

The machine contains the following flags which are 
used by the conditional instructions in this section. 

BRANCH flag — indicates if a branch is to be taken; 
END 07 RECORD flag — indicates that an end of 
input condition has been reached when an attempt was made 
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to read input ? 

OVERFLOW flag — indicates the loss of information 
from a register due to a number exceeding the available 
size? 

INVALID flag — indicates an invalid action in 
writing to a direct access storage device. 

All of the branch instructions are executed by 
changing the value of the program counter. Some are uncon- 
ditional branches and some test for condition flags which 
are set by other instructions. A conditional branch is exe- 
cuted by testing the branch flag which is initialized to 
false. A true value causes a branch by changing the pro- 
gram counter to the value of the branch address. The branch 
flag is then reset to false. A false value causes the pro- 
gram counter to be incremented to the next sequential in- 
struction. 

3RN: (branch to an address). Load the program 

counter with the <branch address>. 

Parameters: <branch address> 

The next three instructions share a common format. 
The memory field addressed by the <memory address> is 
checked for the <address length>, and if all the characters 
match the test condition, the branch flag is complimented 
Parameters: <merrory address> <address length> <branch ad- 

dress> 

CAL: (compare alphabetic). Compare a memory field 
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for alphabetic characters. 

CNS: (compare numeric signed). Compare a field for 

numeric characters allowing for a sign character. 

CNU: (compare numeric unsigned). Compare a field for 
numeric characters only. 

DEC: (decrement a counter and branch if zero). 
Decrement the value of the <address counter> by one? if the 
result is zero before or after the decrement, the program 
counter is set to the <branch address>. If the result is 
not zero, the program counter is incremented by four. 
Parameters: <address counter> <branch address> 

EOR : (branch on END OF RECORD flag). If the END 

OF RECORD flag is true, it is set to false and the program 
counter is set to the <branch address>. If false, the pro- 
gram counter is incremented by two. 

Parameters: <branch address> 

SDP: (go to - depending on). The memory location ad- 
dressed by the <number address> is read for the number of 
bytes indicated by the <memory length>. This number indi- 
cates which of the <branch addresses> is to be used. The 
first parameter is a bound on the number of branch ad- 
dresses. If the number is within the range, the program 
counter is set to the indicated address. An out-of-bounds 
value causes the program counter to be advanced to the next 
sequential instruction. 

Parameters: <bound number - byte> <memory length> <memory 
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address> <branch addr-l> <branch addr-2> ... <branch addr-n> 
INV: (branch if INVALID flag true). If 
the invalid-file-action flag is true, then it is set to 
false, and the program counter is set to the branch ad- 
dress. If it is false, the program counter is incremented 
by two. 

Parameters: <branch address> 

PER: (perform). The code address addressed by the 
<change address> is loaded with the value of the <return ad- 
dress>. The program counter is then set to the Cbranch ad- 
dress)*. 

Parameters: <branch address)* <change address> <return ad- 

dress)* 



RET: (return). If the value of 
is not zero, then the program counter 
and the <branch address)* is set to zero 
dress> is zero, the program counter is 
Parameters: Cbranch address> 

REQ: (register equal). This ins 
zero value in register two. If it is 
is complemented. A conditional branch 
Parameters: <branch address> 

RGT: (register greater than), 
checked for a negative sign. If presen 
complemented. A conditional branch is 
Parameters: <branch address)* 



the <branch address)* 
is set to its value, 
. If the <branch ad- 
incremented by two. 

truction checks for a 
zero, the branch flag 
is taken. 

Register two is 
t , the branch flag is 
taken . 
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HIT: (register less than). Register two is checked 
for a positive sign, and if present, the branch flag is com- 
plemented. A conditional branch is taken. 

Parameters: <branch address> 

SER: (branch on size error). If the overflow flag is 
true, then the program counter is set to the branch address, 
and the overflow flag is set to false. If it is false, then 
the program counter is incremented by two. 

Parameters: <branch address> 

The next three instructions are of similar form in 
that they compare two strings and set the branch flag if 
the condition is true. 

Parameters: <string addr-l> <string addr-2> <length - ad- 

dress> <branch address> 

S2Q: (strings equal). The condition is true if the 
strings are equal. 

SGT: (string greater than). The condition is true if 
string one is greater than string two. 

SLT: (string less than). The condition is true if 
string one is less than string two. 

4. Moves 

The machine supports a variety of move operations 
for various formats and types of data. It does not support 
direct moves of numeric data from one memory field to anoth- 
er Instead, all numeric moves go through the registers. 
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The next seven instructions perform the same 
function. They load a register with a numeric value and 
differ only in the type of number that they expect to see in 
memory at the <number address>. All seven instructions 
cause the program counter to be incremented by five. Their 
common format is given below. 

Parameters: <number address> <byte length> <byte decimal 

count> <byte register to load> 

LOD: (load literal). Register two is loaded with a 
constant value. The decimal point indicator is not set in 
this instruction. The literal will have an actual decimal 
point in the string if required. 

LD1: (load numeric). Load a numeric field. 

LD2: (load postfix numeric). Load a numeric field 

with an internal trailing sign. 

LD3: (load prefix numeric). Load a numeric field 

with an internal leading sign. 

LD4: (load separated postfix numeric). Load a numer- 
ic field with a separate leading sign. 

LD5: (load separated prefix numeric). Load a numeric 
field with a separate trailing sign. 

LD6 : (load packed numeric). Load a packed numeric 

field. 



MEL: (move into alphanumeric edited field). The 
edit mask is loaded into the <to address> to set up the 
move, and then the <from address> information is loaded. The 
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program counter is incremented by ten. 

Parameters: <t o address> <from address> <length of move 
address> <edit mask address> <edit mask length, address> 

MNE : (move into a numeric edited field). First the 
edit mask is loaded into the receiving field, and then the 
information is loaded. Any decimal point alignment required 
will be performed. Truncation of significant digits will not 
set the overflow flag. The program counter is incremented by 
twelve . 

Parameters: <to address> <from address> <address length of 
move> <edit mask address> <address mask length> <byte to de- 
cimal count> <byte from decimal count> 

MOV: (move into an alphanumeric field). The memory 
field given by the <to address> is filled by the from field 
for the <move length> and then filled with blanks in the 
following positions for the <fill count>. 

Parameters: <to address> <from address> <address move 
length> <address fill count> 

STI: (store immediate register two). The contents of 
register two are stored into register zero and the decimal 
count and sign indicators are set. 

Parameters: none. 

The store instructions are grouped in the same order 
as the load instructions. Register two is stored into 
memory at the indicated location. Alignment is performed 
and any truncation of leading digits causes the overflow 
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cause 



flag to be set. All six of the store instructions 
the program counter to be incremented by four. The format 
for these instructions is as follows. 

Parameters: <address to store into> <byte length> <byte de- 

cimal count> 

STO: (store numeric). Store into a numeric field. 

ST1: (store postfix numeric). Store into a numeric 

field with an internal trailing sign. 

ST2: (store prefix numeric). Store into a numeric 

with an internal leading sign. 

ST3: (store separated postfix numeric). Store into a 
numeric field with a separate trailing sign. 

ST4: (store separated prefix numeric). Store into a 
numeric field with a separate leading sign. 

ST5: (store packed numeric). Store into a packed 

numeric field. 

5 . Input-Output 

The following instructions perform input and output 
operations. Files are defined as having the following 
characteristics: they are either sequential or random 

and, in general, files created in one mode are not required 
to be readable in the other mode. Standard files consist 
of fixed length records, and variable length files need not 
be readable in a random mode. Further, there must be 
some character or character string that delimits a variable 
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length record. 

ACC: (accept). Read from the system input device 

into memory at the location given by the <memory address>. 
The program counter is incremented by three. 

Parameters: <memory address> <byte length of read> 

CIS: (close). Close the file whose file control 

block is addressed by the <fcb address>. The program counter 
is incremented by two. 

Parameters: <fcb address> 

DIS: (display). Print the contents of the data field 
pointed to by <memory address> on the system output device 
for the indicated length and advance the line output if 
<flag> is set. The program counter is incremented by four. 
Parameters: <memory address> <byte length> <flag> 

There are three open instructions with the same for- 
mat. In each case, the file defined by the file control 
bloclc referenced will be opened for the mode indicated. The 
program counter is incremented by two. 

Parameters: <fcb address> 

OPN: (open a file for input). 

OPl: (open a file for output). 

0P2: (open a file for both input and output). This 
is only valid for files on a random access device. 

The following file actions all share the same for- 
mat. Each performs a file action on the file referenced by 
the file control block. The record to be acted upon is 
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given by the <record address>. The program counter is in- 
cremented by six. 

Parameters: <FC3 address> Oecord address> <record length - 

address> . 

DLS: (delete a record from a sequential file). Re- 
move the record that was just read from the file. The file 
is required to be open in the input-output mode. 

RDF: (read a sequential file). Read the next record 
into the memory area. 

WTF: (write a record to a sequential file). Append a 
new record to the file. 

RVL: (read a variable length record). 

WVL: (write a variable length record). 

RWS: (rewrite sequential). The rewrite operation 
writes a record from memory to the file, overlaying the last 
record that was read from the device. The file must be open 
in the input-output mode. 

The following file actions require random files 
rather than sequential files. They make use of a random file 
pointer which consists of a <relative address> and a •(re- 
lative length>. The memory field holds the number to be 
used in disk operations or contains the relative record 
number of the last disk action. The relative record number 
is an index into the file which addresses the record being 
accessed. After the file action, the program counter 
is incremented by nine. 



90 



Parameters: <FCB address> <record address> <record length - 

address> <relative address> Crelative length - byte>. 

DLR: (delete a random record). Delete the record ad- 
dressed by the relative record number. 

RRR: (read random relative). Read a random record 
relative to the record number. 

RRS: (read random sequential). Read the next sequen- 
tial record from a random file. The relative record number 
of the record read is loaded into the memory reference. 

RWR: (rewrite a random record). 

VRR : (write random relative). Write a record into 
the area indicated by the memory reference. 

WRS : (write random sequential). Write the next 
sequential record to a random file. The relative record 
number is returned. 

6 . Subroutine Instructions 

The next three instructions are used to transfer 
control to a subroutine and pass the location of formal 
parameters . 

EXT: (exit subroutine). The program counter is set 

to the last value on the return stack and the actual 
partameters on the parameter stack are removed revealing any 
parameters that may be needed in the calling procedure. 
Parameters: No parameters are required. 

SBR: (call a subroutine). The program counter is 
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set to the beginning address of the called procedure. The 
return address is added to the return stack. 

Parameters: <procedure name-8 bytes> 

PAR: (parameter list). The parameters are added to 

the parameter stack. 

Parameters: <number of parameters> <address parameter 1> 

<address parameter 2> 

7. Special Instructions 

The remaining instructions perform special functions 
required by the machine that do cot relate to any of the 
previous groups. 

NEC-: (negate). Complement the value of the branch 

flag. 

Parameters: No parameters are required. 

LEI: (load a code address direct). Load the coae 
address located five bytes after the LEI instruction with 
the contents of <memory address> after it has been converted 
to binary. 

Parameters: <memory address> <length - byte> 

SCR: (calculate a subscript). Load the subscript 
stack with the value indicated from memory. The address 
loaded into the stack is the <initial address> plus an 
offset. Multiplying the <field length> by the number in the 
<memory reference> gives the offset value. 

Parameters: <initial address> <field length> <memory refer- 
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ence> <nemory length> <stack level> 

STD: (stop display). Display the indicated informa- 
tion and then terminate the actions of the machine. The 
operator is given a choice to allow the machine to continue 
or to terminate its actions. 

Parameters: <memory address> Clength - byte> 

STP: (stop). Terminate the actions of the machine. 
The following instructions are actually instructions to the 
build program in setting up the machine enviromnent and are 
not used in the normal execution of the machine. 

Parameters: no parameters are required. 

BST: (backstuff). Resolve a reference to a label. 

Labels may be referenced prior to their definition, requir- 
ing a chain of resolution addresses to be maintained in the 
code. The latest location to be resolved is maintained in 
the symbol table and a pointer at that location indicates 
the next previous location to be resolved. A zero pointer 
indicates no prior occurrences of the label. The code ad- 
dress referenced by <change address> is examined and if 
it contains zero, it is loaded with the <new address>. If 
it is not zero, then the contents are saved, and the 
process is repeated with the saved value as the change ad- 
dress after loading the <new address>. 

Parameters: <change address> <new address> 

INT: (initialize memory). Load memory with the <in- 
put string> for the given length at the <memory address>. 
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Parameters: Cmemory address> <address length> <input 

string> 

SCI): (start code). Set the initial value of the pro- 
gram counter. 

Parameters: <start address> 

TER: (terminate). Terminate the initialization pro- 
cess and start executing code. 

Parameters: no parameters are required. 
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IV. SYS TEN DEBUGGING METHODS AND TOOLS 



A. DEBUGGING METHODOLOGY 

Initial debugging began with implementation of key- 
components of the compiler/interpreter that had prevented 
use of the Navy's ADPESO validation test programs. 
Additional work on the validation test programs was 
necassary to eliminate and/or correct minor errors within 
the test programs themselves. Once these errors were 
corrected the compiler/interpreter was able to compile and 
execute the ADPESO programs completely and an overall view 
of the problems and errors within the system was available 
for analysis. 

Since compile time for each of the three main. modules — 
PART ONE, PART TWO, and INTERP — took a mimimum of 
forty-five minutes, a step-wize refinement technique was 
employed. First the simplest problems were corrected all at 
the same time. Once this was accomplished the remaining 
problems were handled one at a time to prevent introducing 
new problems from side effects of the corrections. Debugging 
could then be confined to only one problem and side effects 
kept to a minimum. This technique required more compilations 
but it was felt that attempting to correct more than one 
problem at a time could cause severe side effects with an 
increase in overall debugging time. 
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E. INTERACTIVE TOOLS 



Because the MICRO-COBOL compiler and interpreter were 
implemented under the CP/M operating system, the Symbolic 
Instruction Debugger [7], SID, which expands upon the 
features of the Dynamic Debugging Tool [8] , DDT, was 
employed. Specifically, SID includes real-time breakpoints, 
fully monitored execution, symbolic disassembly, assembly, 
and memory display and fill functions. One feature which 
allowed the setting of breakpoints at actual memory 

locations corresponding to a program's source lines and 
symbolic names was used quite extensively. Another useful 
facility was the ability to display and alter the programs 
symbolic values, which enabled the substitution of values to 
check a proposed solution to an error. 

C. CROSS REFERENCE LISTINGS 

Another useful facility which eased the debugging effort 
was the cross reference listings produced by the PLM80 
compiler used to compile the MICRO-COBOL compiler and 
interpreter. There were three different listings produced 
after each compilation: 1.) a line numbered source listing, 

2. ) a symbol address table, which included the name and 
actual memory address assigned for all symbols declared, and 

3. ) a line address table which cross referenced every line 
in the source listing with the 8080 code generated by the 



96 



PLM80 compiler for that particular line. These listings were 
almost indispensable with regard to testing and debugging, 
and their contribution cannot be overemphasized. 



D. VALIDATION TESTS 



The primary method for discovering er 
HYPO-COEOL Compiler Validation System (ECCVS) 
Automated Data Processing Equipment Sele 
(ADPESO)). The transfer of these test program 
a usable form on floppy diskettes was accompli 
and Perry [14]. Additional errors were disco 
several additional test programs written to t 
were not tested by the ADPESO programs or co 
were not contained in the HYP0-C030L specifica 



rors was the 
Tape (from the 
ction Office 
s from tape to 
shed by Kiefer 
vered through 
est areas that 
r.structs that 
ti ons . 
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V . CONCLUSIONS AND RECOMMENDATIONS 



The entire MICRO-COBOL Compiler/Interpreter has been 
tested, debugged and documented. The following specific 
language features and facilities previously not implemented, 
or implemented incorrectly, have been successfully 
implemented, tested and debugged during this project: 1.) 
the compiler's ability to handle any sequence of MICRO-COBOL 
language constructs (PIC CLAUSE, VALUE CLAUSE, OCCURS 
CLAUSE, and USAGE COMP-3 CLAUSE) in the declaration of an 
identifier, 2.) record identifier declarations with up to 
ten levels of elementary field items, 3.) record and 
elementary field identifier redefinitions, 4.) nested 
redefinitions, and 5.) error message generation for 
duplicate identifier declarations within the DATA DIVISION, 
rework of the BCD arithemetic package including the ROUND 
and SIZE ERROR options, ?.) implementation of the Move 
Numeric Edited command, 9.) implementation of nested 
IF-THEN-ELSE statements, 9.) implementation of the PERFORM 
VARYING clause, 12.) modification of all MOVE commands, 11.) 
modification of the EXIT clause for use with subroutines, 
12.) modification of the STOP DISPLAY clause to allow 
operator restart, 13.) implementation of subroutines 
including the CALL, USING and LINKAGE SECTION clauses, 14.) 
modification of the WRITE BEFORE/AFTER clause, 15). 
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i nr?"D 1 eme n t a t i on of COMP-3 and SIGN LEADING/TRAILING options, 
16,) addition of the list and code compiler toggles to 
include a list file with errors and line numbers and the 
capability of surpressing code generation for rapid syntax 
checking, and 17) expansion of the grammar to include the 
COMPUTE verb, the logical operators "AND" and ”0P.", indexed 
files, and the relational operators ”<" , ”>", and 

N PS MICRO-COBCL compiles at a rate of approximately 500 
lines per minute using a Z-80 microprocessor with a 4MEZ 
clock on a standard eight inch floppy diskette. With the use 
of optional toggles such as NOSCODE or NO$LIST compilation 
rate increases to approximately 700 lines per minute and a 
maximum rate of approximately 900 lines per minute with both 
NOSCODE and N0$LIST toggles selected. Memory usage is kept 
to a minimum through the use of overlays thus allowing 
fairly complex COBOL programs to be written and executed on 
a modest size microcomputer system. The present development 
system is designed to run in only 48K of main memory and can 
run in as little as 20K or as much as the 64K maximum 
address space of an 8080 or Z-80 microcomputer. These two 
features in addition to clear error diagnostics make the NPS 
MICRO-COBOL compiler/interpreter an excellent tool for 
teaching introductory COEOL programming. 

NPS MICRO-COBOL has been validated by the complete 
ADPESO validation test package for HYPO-COBOL. In addition 
to the twenty-five test programs from that package, several 
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test programs designed to test the additional features 
implemented which were not in EYP0-C0B0L and several 
application programs have been compiled and executed to the 
sum of approximately 50,000 lines of COBOL code. 

In addition, the NPS MICRO-COBOL compiler documentation 
has been updated. This documentation includes the following: 
1.) module organization, 2.) module interfaces, 3.) memory 
organization of the Interpreter, 4.) construction and data 
initialization of the symbol table, and 5.) key internal 
data structures. 

Several areas remain which could be implemented to 
enhance the NPS MICRO-COBOL compiler/interpreter system, 
these include: 1.) implementation of the COMPUTE verb, 2.) 
implementation of multiple Open's, and Close's, 3.) 
implementation of multi-dimensional tables, 4.) 
implementation of the logical operators "AND" and ’ CP." , and 
5.) implementation of the optional comparison operators "<", 

M *» •( •• 

> , and = . 
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APPENDIX A 



N PS MICRO-COBOL USER'S MANUAL 
VERSION 2.0 
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I . ORGANIZATION 



The compiler is designed to run on an 8080 system in an 
interactive mode through the use of a teletype or console. 
It requires at least 24K of main memory and a mass storage 
device for reading and writing. The compiler is composed of 
two parts , each of which reads a portion of the input file. 
Part One reads the input program to the end of the Data 
Division and builds the symbol table. At the end of the Data 
Division, Part One is overlayed by Part Two which uses the 
symbol table to produce the code. The output code is written 
as it is produced to minimize the use of internal storage. 



The EXEC 


Program builds 


the 


core imasre for 


the 


intermediate 


code and performs 


such functions 


as 


backstuf f i ng 


addresses and 


offsetting address 


in 



subroutines. EXEC then copies the i nterpreter(CINTERP . COM) 
into memory and transfers control to the it. The interpreter 
is controlled by a large case statement that decodes the 
instructions and performs the required actions. 
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II. MICRO-COBOL ELEMENTS 



This section contains a description of each element in 
the language and shows simple examples of their use. The 
following conventions are used in explaining the formats: 
Elements enclosed in broken braces < > are themselves 
complete entities and are described elsewhere in the manual. 
Elements enclosed in braces { } are choices, one of the 
elements which is to be used. Elements enclosed in brackets 
[ 1 are optional. All elements in capital letters are 
reserved words and must be spelled exactly. 

User names are indicated in lower case. These names are 
unrestricted in length, however they must be unique within 
the first 15 characters. The only other restriction on user 
names is that the first character must be an alpha 
character. The remainder of the user name can have any 
combination of representable characters in it. 

The input to the compiler does not need to conform to 
standard COBOL format. Free form input will be accepted as 
the default condition. If desired, sequence numbers can be 
entered in the first six positions of each line. However, a 
toggle needs to be set to cause the compiler to ignore the 
sequence numbers. 
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The first character position on any line is used to 



indicate the following:- 



* - indicates a comment entry. 



: - indicates a debugging line. 



/ - indicates a page eject. 



105 



IDENTIFICATION DIVISION 



ELEMENT : 

IDENTIFICATION DIVISION Format 



FORMAT: 



IDENTIFICATION DIVISION. 

PROGRAM-ID. <comment>. 

[AUTHOR. <comment>.] 

[DATE-WRITTEN. <comment>.] 

[SECURITY. <comment> .] 

DESCRIPTION: 

This division provides information for 
tification for the reader. The order o 
fixed. 

EXAMPLES : 

IDENTIFICATION DIVISION. 

PROGRAM-ID. SAMPLE. 

AUTHOR. HAL R POWELL. 



program iden- 
f the lines is 
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ENVIRONMENT DIVISION 



ELEMENT : 



ENVIRONMENT DIVISION Format 



FORMAT: 

[ ENVIRONMENT DIVISION. 

CONFIGURATION SECTION. 

SOURCE-COMPUTER. <comment> [DEBUGGING MODE] . 
OBJECT-COMPUTER. <comment>. 

[INPUT-OUTPUT SECTION. 

FILE-CONTROL. 



<file-control-entry> 



[I -0 -CONTROL. 



SAME file-name-1 file-name-2 [file-name-3] 



[file-name-4] [file-name-5]. ] ] ] 



DESCRIPTION: 

This division determines the external nature of a 
file. In the case of CP/M all of the files used can he 
accessed either sequentially or randomly except for 
variable length files which are sequential only. The 
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debugging mode is also set by this section. The 
DEBUGGING MODE clause is used in conjunction with the 
to indicate conditional compilation. If this 
clause is specified all debugging lines (those with a 
in column one) are compiled. If this clause is not 
specified, all debugging lines are treated as 

comments. In addition the DEBUGGING MODE can be 
specified by using the compiler toggle 'D ' . 
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<f 11 e-con trol-entry> 



ELEMENT: 

<f 11 e-con trol -entry > 

FORMAT: 

1 . 

SELECT file-name 

ASSIGN implementor-name 
[ORGANIZATION SEQUENTIAL] 

[ACCESS SEQUENTIAL]. 

2 . 

SELECT file-name 

ASSIGN implementor-name 
ORGANIZATION RELATIVE 

[ACCESS [SEQUENTIAL [RELATIVE da ta-name] }] . 
[RANDOM RELATIVE data-name } 

3. 

SELECT file-name 
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ASSIGN implementor-name 



ORGANIZATION INDEXED 
[ACCESS {SEQUENTIAL}] . 
{RANDOM } 



DESCRIPTION: 

The file-control-entry defines the type of 
the program expects to see. There is no di 
the diskette, hut the type of reads and w 
are performed will differ. Eor CP/M the 
name needs to conform to the normal specifi 
Indexed is not implemented. 

EXAMPLES: 

SELECT CARDS ' 

ASSIGN CARD.EIL. 

SELECT RANDOM-FILE 

ASSIGN A. RAN 

ORGANIZATION RELATIVE 

ACCESS RANDOM RELATIVE RAND-ELAG. 



file that 
fference on 
rites that 
implementor 
cations . 
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DATA DIVISION 



ELEMENT: 

DATA DIVISION Format 
FORMAT: 

DATA DIVISION. 

[FILE SECTION. 

[FE file-name 

[BLOCK integer-1 RECORDS] 

[RECORD [integer-2 TO] integer-3] 

[LABEL RECORDS [STANDARD}] 

(OMITTED } 

[VALUE OF irrplerrentor-name-1 literal-1 

[implementor-name-2 literal-2] ... ]. 
[<record-descripti on-ent ry>] . . .] ... 

[WORKING- STORAGE SECTION. 
[<record-description-entry>] ... ] 

[LINKAGE SECTION. 
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[<record-description-entry>] ... ] 

DESCRIPTION : 

This is the section that describes how the data is 
structured. There are no major differences from stan- 
dard COBOL except for the following: 1. Label 

records make no sense on the diskette so no entry is 
required. 2. The VALUE 0? clause likewise has no 
meaning for CP/M. If a record is given two lengths as 
in RECORD 12 TO 123, the file is taken to be variable 
length and can only be accessed in the sequential 
mode. See the section on files for more information. 
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<comment> 



ELEMENT: 

<comment> 



FORMAT: 



any string of characters 
DESCRIPTION : 



A comment 


is a 


string of 


characters. It 


may 


i nc lude 


anything 


other 


than a period followed by 


a bl 


ank or a 


reserved 


word , 


either of 


which terminate 


the 


string. 


Comments 


may 


be empty i 


f desired, but the te 


rmi nat or 


is still 


required by the 


program. 







EXAMPLES : 

this is a comment 

anotheroneallruntogether 

8080 b 16 K 
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<data-description-entry> 



ELEMENT : 

<data-description-entry> Format 
FORMAT: 

level-number {data-name} 

{FILLER } 
[REDEFINES data-name] 

[PIC character-string] 

[USAGE [COMP }] 

[COMP-3] 

[COMPUTATIONAL] 

[DISPLAY] 

[SIGN [LEADING] [SEPARATE]] 
[TRAILING] 

[OCCURS integer] 

[SYNC [LEFT ]] 

[RIGHT] 
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[VALUE literal] 



DESCRIPTION: 

This statement describes the specific attributes of 
the data. Since the 80S0 is a byte machine, there was 
no meaning to the SYNC clause, and thus it has not 
been implemented, however existing programs that are 
transfered to MICRO-COBOL and use this feature will 
compile and execute successfully. All numeric data are 
maintained in DISPLAY format or packed BCD if the 
COMP-3 option is used. 

EXAMPLES: 

01 CARD-RECORD. 

02 PART PIC X (5) . 

02 NEXT-PART PIC 99V99 USAGE DISPLAY. 

02 FILLER. 

03 NUMB PIC S9(3)V9 SIGN LEADING SFPARATE . 

03 LONG-NUMB 9(15). 

03 STRING REDEFINES LONG-NUMB PIC X(15). 

02 ARRAY PIC 99 OCCURS 100. 
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PROCEDURE DIVISION 



ELEMENT: 

PROCEDURE DIVISION Format 
FORMAT: 

1 . 



PROCEDURE DIVISION [USING narrel [name?] 
section-name SECTION. 

[paragraph-name. <sentence> [<sentence> 

2 . 

PROCEDURE DIVISION [USING namel [name2] 
paragraph-name. <sentence> [<sentence> . 
DESCRIPTION: 

As is indicated, if the program is to 
tions, then the first paragraph must he 



. . [name5] ] . 

.. 1 ... ] ... 

. . [name5] ] . 

■ 1 ... 

contain sec- 
in a section. 
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<sentence> 



ELEMENT: 

<sentence> 

FORMAT: 

<imperative-sta tement> 
<condi tional-statement> 
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<imperative-statement> 



ELEMENT: 

<imperati ve-sta tement> 

FORMAT: 

The following verbs are always imperatives: 

ACCEPT 

CALL 

CLOSE 

DISPLAY 

EXIT 



GO 

MOVE 

OPEN 

PERFORM 

STOP 

The following may he imperatives: 

arithmetic verbs without the SIZE ERROR statement 

and DELETE, WRITE, and REWRITE without the INVALID option. 
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<condi tional-sta tement s> 



ELEMENT: 

<condi tional-sta tement s> 



FORMAT: 



IF 

READ 

arithmetic verbs with the SIZE ERROR statement 

and DELETE, WRITE, and REWRITE with the INVALID option. 
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ACCEPT 



ELEMENT: 

ACCEPT 



FORMAT: 



ACCEPT <iden tif ier> 

DESCRIPTION: 

This statement reads up to 255 characters from the 
console. The usage of the item must he DISPLAY. 
EXAMPLES: 

ACCEPT IMMAGE. 

ACCEPT NUM ( 9 ) . 
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ADD 



ELEMENT: 

ADD 



FORMAT: 



ADD {identlfier-1} [{identifier-2 }] ... TO identifier-m 

{literal-1 } {literal-2 } 

[ROUNDED] [SIZE ERROR <imperative-statement>] 
DESCRIPTION: 

This instruction adds either one number to a 
second with the result being placed in the last loca- 
tion. Multiple adds have not been implemented. 

EXAMPLES: 

ADD 10 TO NUM31 

ADD X TO Z ROUNDED. 

ADD 100 TO NUMBER SIZE ERROR GO ERROR-LOC 
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CALL 



ELEMENT: 

CALL 



FORMAT : 



CALL literal [USING namel [name2] ... [nameN]] 
DESCRIPTION : 

Control is transfered to the called procedure with an 
address of each of the parameters to be passed. The 
parameters map to those in the linkage section of the 
called program. The type and size of the parameters 
must match exactly. 

EXAMPLES : 

CALL 'NC152' USING DN1 
CALL 'PRINT' 

CALL 'ADDLIST ' USING VAR1 VAR2 VAR3 
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CLOSE 



ELEMENT: 

CLOSE 

FORMAT: 

CLOSE file-name 
DESCRIPTION: 

Files must be closed if they have been written. How- 
ever, the normal requirement to close an input file 
prior to the end of processing does not exist. 
EXAMPLES: 

CLOSE FILE1 

CLOSE RANDFILE 
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DELETE 



ELEMENT: 

DELETE 

FORMAT: 

DELETE file-name [INVALID <imperative-statement>] 
DESCRIPTION: 

This statement requires the file-name of the item 
to be deleted. The record is logically removed by 
filling it with a high value character, vhich is not 
displayable to the console or line printer. The log- 
ical record space can be used again by writing a 
valid record in its place. 

EXAMPLES: 

DELETE FILE-NAME 
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DISPLAY 



ELEMENT: 

DISPLAY 



FORMAT: 



DISPLAY {identifier} [{identifier-1}] . . . [{identif ier-N}] 



{literal } 


{literal-1 


} . 


. . {literal- 


DESCRIPTION: 








This displays the 


contents of 


an 


identifier or 


displays a literal 


on the con 


sole. 


Usage must he 


DISPLAY. The maximum 


length of the 


display is 80 char- 


acters for literal 


values and 


255 


characters for 


identifiers . 









EXAMPLES : 

DISPLAY MESSAGE-1 

DISPLAY MESSAGE-3 10 

DISPLAY 'THIS MUST BE THE END' 
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DIVIDE 



ELEMENT: 

DIVIDE 



FORMAT: 



DIVIDE {identifier} INTO identifier-1 [ROUNDED] 
{literal } 

[SIZE ERROR <impera tive-statement>] 

DESCRIPTION: 

The result of the division is stored in identifier-1 ; 
any remainder is lost. 

EXAMPLES: 

DIVIDE NUME INTO STORE 
DIVIDE 25 INTO RESULT 
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EXIT 



ELEMENT: 

EXIT 



FORMAT: 



EXIT [PROGRAM] 
DESCRIPTION: 



The 


EXIT command causes 


no action 


by 


the 


interpreter 


but 


allows for an empty 


paragraph 


for 


the 


construction 



of a common return point. The optional PROGRAM termi- 
nates a subroutine and returns to the calling program. 
It's use in the main program couses no action to be 
taken. 

EXAMPLES : 

EXIT PROGRAM 

EXIT 
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C-0 



ELEMENT: 

GO 

FORMAT: 

1 . 

GO procedure-name 

2 . 

GO procedure-1 [procedure-2] ... procedure-20 
DEPENDING identifier 
DESCRIPTION: 

The GO command causes an unconditional branch 
routine specified. The second form causes a 
branch depending on the value of the contents 



identifier . 


The 


identifier 


must 


be 


a numeric 


value. There 


can 


be no more 


than 


20 


procedure 



EXAMPLES : 

GO READ-CARD. 



to the 
forward 
of the 
integer 
names . 
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GO READ1 READ2 READ3 DEPENDING RE*D-INDEX. 
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IF 

ELEMENT: 

IF 

FORMAT: 

IF <condition> {stmt-lst } END-IF 

IF <condition> {stmt-lst } ELSE {stmt-lst} END-IF 

{NEXT SENTENCE} {NEXT SENTENCE} 

DESCRIPTION: 

This is an enhanced version of the standard COBOL IF 
statement. Nesting of IF statements is allowed. 

EXAMPLES: 

IF A GREATER B ADD A TO C ELSE GO ERROR-ONE END-IF. 

IF A NOT NUMERIC NEXT SENTENCE ELSE MOVE ZERO TO A END-IF. 
IF A LESS B 
DISPLAY A 
DISPLAY B END-IF. 

IF A GREATER B 
DISPLAY A 
DISPLAY B 
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ELSE 



DISPLAY C 
DISPLAY D END-IF. 
IF A GREATER B 
IF A GREATER C 
DISPLAY A 
ELSE 

DISPLAY C 
END-IF 
ELSE 

IF B GREATER C 
DISPLAY B 
ELSE 

DISPLAY C 
END-IF 
END-IF. 
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MOVE 



ELEMENT: 

MOVE 

FORMAT: 

MOVE {identifier-1} TO identifier-2 
{literal } 

DESCRIPTION: 

The standard list of allowable moves applies to this 
action. As a space saving feature of this implementa- 
tion, all numeric moves go through the accumulators. 
This makes numeric moves slower than alpha-numeric 
moves, and where possible they should be avoided. Any 
move that involves picture clauses that are exactly 
the same can be accomplished as an alpha-numeric move 
if the elements are redefined as alpha-numeric; also 
all group moves are alpha-numeric. 

EXAMPLES: 

MOVE SPACE TO PRINT-LINE. 

MOVE A (10 ) TO E(PTR). 
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MULTIPLY 



ELEMENT: 

MULTIPLY 

FORMAT: 

MULTIPLY {identifier} BY identifier-2 [ROUNDED] 
{literal } 

[SIZE ERROR <imperati ve-statement>] 

DESCRIPTION: 

The multiply routine uses a double length register to 
calculate the result. This allows the result generated 
to be of maximum precision. The actual value stored 
will be determined by the amount of storage allocated 
for the variable. Overflow will occur if the number in 
the register is larger than the variable. If the 
precision in the register is greater than the variable 
trucation occurs unless the round option is specified. 
EXAMPLES : 

MULTIPLY X BY Y. 

MULTIPLY A BY B(7) SIZE ERROR GO OVERFLOW. 
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OPEN 



ELEMENT: 

OPEN 



FORMAT: 



OPEN {INPUT file-name-1 } [{file-name-2}] ... 
{OUTPUT file-name-1} [{file-name-2}] ... 
{ I — 0 file-name-1 } [{file-name-2}} ... 



DESCRIPTION : 

The three types of OPENS have exact 
on the diskette. However, they do 
checking of the other file actions, 
write to a file set open as input 
error. Multiple opens have not been 



ly the same effect 
allow for internal 
For example, a 
will cause a fatal 
impl emented . 



EXAMPLES : 

OPEN INPUT CARDS. 



OPEN OUTPUT REPORT-FILE. 



PERFORM 



ELEMENT : 

PERFORM 

FORMAT: 

1 . 

PERFORM procedure-name [THRU procedure-name-2] 

2 . 

PERFORM procedure-name [THRU procedure-name-2] 
{identifier} TIMES 
{integer } 

3. 

PERFORM procedure-name [THRU procedure-name-2] 
UNTIL <condi tion> 

4. 

PERFORM procedure-name VARYING {identifier} 
FROM {identifier} BY {identifier} 

UNTIL <condi ti on> 
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DESCRIPTION: 



All four options are supported. Branching may be ei- 
ther forward or backward, and the procedures called 
may have perform statements in them as long as the end 
points do not coincide or overlap. 

EXAMPLES : 

PERFORM OPEN-ROUTINE. 

PERFORM TOTALS THRU END-REPORT. 

PERFORM SUM 10 TIMES. 

PERFORM SKIP-LINE UNTIL PG-CNT GREATFR 60. 

PERFORM REPEAT-AGAIN VARYING COUNTER FROM 1 BY 2 
UNTIL COUNTER EQUAL 10. 
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READ 



ELEMENT: 

READ 

FORMAT: 



1 . 



READ file-name INVALID <imperative-staterrent> 



2 . 



READ file-name END <imperative-statement> 

DESCRIPTION: 

The invalid condition is only applicable to files in a 
random mode. All sequential files must have an END 
statement . 

EXAMPLES: 

READ CARDS END GO END-OF-FILE. 

READ RANDOM-FILE INVALID MOVE SPACES TO REC-1 . 
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REWRITE 



ELEMENT: 

REWRITE 



FORMAT: 



REWRITE record-name [INVALID <impera tive>] 



DESCRIPTION : 

REWRITE is only valid for files that are open i 
1-0 mode. The INVALID clause is only valid for 
files. This statement results in tne current 
being written bacic into the place that it wa 
read from, the last executed read. 

EXAMPLES : 

REWRITE CARDS. 



REWRITE RAND-1 INVALID PERFORM ERROR-CHECK. 



n the 
random 
record 
s just 
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STOP 



ELEMENT: 

STOP 



FORMAT: 



STOP {RUN } 
{literal} 



DESCRIPTION: 

This statement stops execution of the program. If a 
literal is specified, then the literal is displayed on 
the console and a prompt is displayed giving tne 
operator the option of terminating or continuing 
program execution. 

EXAMPLES: 

STOP RUN. 

STOP 1. 

STOP 'INVALID FINISH'. 

For the last two examples the following prompt is 
displayed : 

OPERATOR ENTER A <CR> TO CONTINUE 
OR ENTER AN "s" TO TERMINATE. 
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SUBTRACT 



ELEMENT: 

SUBTRACT 



FORMAT: 



SUBTRACT {iaentifier-1} [identifier-2] ... FROM identifier-m 
{literal-1 } [literal-2 ] 

[ROUNDED] [SIZE ERROR <i mperat i ve-sta tement>] 

DESCRIPTION: 

Identifier-m is decremented by the value of 
identifier/literal one. The results are stored back 
in identifier-m. Rounding and size error options are 
available if desired. Multiple subtracts have not been 
implemented . 

EXAMPLES: 

SUBTRACT 10 FROM SUB(12). 

SUBTRACT A FROM C ROUNDED. 
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WHITE 



ELEMENT: 

WRITE 



FORMAT: 

1 . 



WRITE record-name [{BEFORE} ADVANCING {INTEGER}] 

{AFTER } {PAGE } 



2 . 

WRITE record-name INVALID <imperative-s tatement> 
DESCRIPTION: 

The record specified is written to the file 
specified in the file section of the source 
program. The INVALID option only applies to 
random files. 

EXAMPLES: 

WRITE OUT-FILE. 

WRITE RAND-FILE INVALID PERFORM ERROR-RECOV. 
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<condi ti on> 



ELEMENT: 

<condi t ion> 



FORMAT: 

RELATIONAL CONDITION: 

{identifier-1} [NOT] {GREATER} {identifier-2} 
{literal-1} {LESS } {literal-2 } 

{EQUAL } 

CLASS CONDITION: 

identifier [NOT] {NUMERIC } 

{ALPHABETIC} 

DESCRIPTION : 

It is not valid to compare two literals. The 
condition NUMERIC will allow for a sign if the 
tifier is signed numeric. 

EXAMPLES: 

A NOT LESS 10. 

LINE GRFATER 'C'. 

NUMB1 NOT NUMERIC 



class 

iden- 
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Subscripting 



ELEMENT: 

Subscripting 

FORMAT: 

data-name (subscript) 

DESCRIPTION: 

Any item defined with an OCCURS may be referenced by 
a subscript. The subscript may be a literal integer, 
or it may be a data item that has been specified as an 
integer. If the subscript is signed, the sign must be 
positive at the time of its use. 

EXAMPLES : 

A ( 10 ) 

ITEM (SUB ) 
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III. COMPILER TOGGLES 



There are sii compiler toggles which are controlled by 
an entry following the compiler activation command, COBOL 
<filename>. The format of the entry consists of following 
<filename> by one space and then entering a followed 

immediately by the desired toggles. There must be only one 
space after <filename> and no spaces between the ’ and the 
toggles. The following is an example of a typical entry: 
COBOL EXAMPLE $S 

This entry would cause the compiler to ignore the first six 
characters (used for sequence numbers) at the beginning of 
each input line. In each case the toggle reverses the 
default value. 



$C — No intermediate code. Default is off. Setting this 
toggle speeds initial compilation for syntax checking. When 
this toggle is set the "CIN" file is empty. 



$D — Debugging mode. Default is off. This toggle sets 
the debugging mode, which means all debugging lines(those 
with a in column one) are compiled. If this toggle is 
not set and the DEBUGGING MODE is not set in the ENVIRONMENT 
DIVISION of the source program all debugging lines are 
treated as comments. 

$L — list the input code on the screen as the program 
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is compiled. Default is on. Error messages are displayed at 
the terminal in any case. 

$P — Productions. List productions as they occur. 
Default is off. 

$S — sequence numbers are in the first six positions of 
each record. Default is off. 

$T — Tokens. List tokens from the scanner. Default is 

off. 

$W — Create a list file. Default is off. A listing file 
is created when this toggle is set. When this toggle is not 
set the "LST" file will only contain error messages. 
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IV. RUN TIMS CONVENTIONS 



This section explains how to run the compiler on the 
current system. The compiler expects to see a file with a 
type of CBL as the input file. In general, the input is free 
form. If the input includes sequence numbers then the 
compiler must he notified by setting the appropriate toggle. 
The compiler is started by typing COBOL <file-name>. Where 
the file name is the system name of the input file. There is 
no interaction required to start the second part of the 
compiler. The output file will have the same <file-name'> as 
the input file, and will be given a file type of CIN. Any 
previous copies of the file will be erased. As with the CIN 
file a LST file will be created with the same file name as 
the input file and any previous LST files with that name 
will be erased. 

The interpreter is started by typing EXEC <filename>. 
The first program is a loader, and it will display ”NPS 
MlCRO-COBOL LOADER VERS 1.0” followed by the display "LOAD 
FINISHED" to indicate successful completion. The run-time 
package will be brought in by the EXEC routine, and 
execution should continue without interruption. Succesful 
transfer of control to the interpreter will be indicated by 
the display "NPS KICRO-COBOL INTERPRETER VERS 1.0". 
Completion of program exection will be indicated by the 
display " X EXECTION ERROR(S)", where ”x” is the number of 
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errors which 



occured during execution. 
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V. FILE INTERACTIONS WITH CP/M. 



The file structure that is expected, by the program 
imposes some restrictions on the system. References 4 and 5 
contain detailed information on the facilities of CP/M, and 
should be consulted for details. The information that has 
been included in this section is intended to explain where 
limitations exist and how the program interacts with the 
system. 

All files in CP/M are on a random access device, and 
there is no way for the system to distinguish sequential 
files from files created in a random mode. This means that 
the various types of reads and writes are all valid to any 
file that has fixed length records. The restrictions of the 
ASSIGN -statement prevent a file from being open for both 
random and sequential actions during one program. 

Each logical record is terminated by a carriage return 
and a line feed. In the case of variable length records, 
this is the only end mark that exists. This convention was 
adopted to allow the various programs which are used in CP/M 
to work with the files. Files created by the editor, for 
example, will generally be variable length files. This 
convention removes the capability of reading variable length 
files in a random mode. 

All of the physical records are 128 bytes in length, and 
the program supplies buffer space for these records in 
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addition to 
any desired 



the logical records. Logical records may he of 
length. 
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VI. ERROR MESSAGES 



A. COMPILER FATAL MESSAGES 



EP. Bad read — disk error, no corrective action can be 
taken in the program. 

CL Close error — unable to close the output file. 

MA Make error — could net create the output file. 

MO Memory overflow — the code and constants generated 

will not fit in the alloted memory space. 

OP Open error — can not open the input file, or no such 
file present. 

SO Stack overflow — the LALR(l) parsing stack has exceeded 
its maximum allowable size. 

ST Symbol table overflow — symbol table is toe large for 
the allocated space. 

WR Write error — disk error, could not write a code 

record to the disk. 



E. COMPILER WARNINGS 



CC 



CE 



Carriage Control error — The WRITE EEFORE/AFTER 
ADVANCING option can only be used with sequential files 
Close error — attempted to close a non-existing file. 
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DD Duplicate Declaration — the identifier name has been 
previously declared. 

EL Extra levels — only 10 levels are allowed. 

FT File type — the data element used in a read or write 

statement is not a file name. 

IA Invalid access — the specified options are not an 
allowable comoination. 

ID Identifier stack overflow — more than 20 items in a 

GO — DEPENDING statement. 

IS Invalid subscript — an item was subscripted but it 

was not defined by an OCCURS . 

IT Invalid type — the field types do not match for this 

statement . 

LE Literal error — a literal value was assigned to an 

item that is part of a group item previously assigned 
a value. 

LV Literal value error — the PICTURE clause field type 
does not match the VALUE clause literal type. 

L7 Level 77 error — level 77 used incorrectly. 

MD Multiple decimals — a numeric literal in a VALUE 
clause contains more than one decimal point. 

MS Multiple signs — a signed numeric literal in a VALUE 
clause contains more than one sign. 

NF No file assigned — there was no SELECT clause for 

this file. 

NI Not implemented — a production was used that is not 
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implemented . 

NN Non-numeric — an invalid character was found in a 

numeric string. 

NP No production — no production exists for the cuurrent 
parser configuration? error recovery will automatically 
occur . 

NV Numeric value — a numeric value was assigned tc a 

non-numeric item. 

OE Open error — attempt to open a file that was not de- 
clared; or attempted to open a file for 1-0 that was 
not a RELATIVE file. 

OL OCCURS LEVEL — 01 and 77 levels can not contain an 
occurs clause. 

PC Picture clause — a pic clause exceeds 20 characters. 

PI More than one float symbol declared. 

P2 Non-numeric data in repetition clause or missing right 
parenthesis . 

P3 Invalid or incompatable symbol in pic clause. 

P4 Invalid symbol(s) embedded within a float symbol 

only allowed. 

P5 Invalid combination of symbols in pic clause, type cannot 
be determined. 

P6 Number of possible numeric entries exceeds register length 
max is 18. 

PE Paragraph first — a section header was produced after 
a paragraph header, which is not in a section. 
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R1 Redefine nesting — a redefinition was made for an 
item which is part of a redefined item. 

R2 Redefine length — the length of the redefinition item 
was greater than the item that it redefined. That 
is only allowed at the 01 level. This error 
message may he printed out one identifier past the 
redefining identifier record in which it occurred. 

R3 Redefines misplaced — a redefines was attempted in the 
FILE SECTION of the source program. 

SE Scanner error — the scanner was unable to read an 

identifier due to an invalid character. 

SG Sign error — either a sign was expected and not 

found, or a sign was present when not valid. 

SL Significance loss — the number assigned as a value is 
larger than the field defined. 

TE Type error — the type of a subscript index is not 
integer numeric. 

UD Undeclared identifier — the identifier was not 
declared . 

UL Unresolved label — label has not been referenced. 

This warning will be given to all references to 
external subroutines. 

VE Value error — a value statement was assigned to an 
item in the file section. 

WL Wrong level error — program attempted to write a 
record other than an 01 level record to an output 
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file 



C. INTERPRETER FATAL ERRORS 



CL Close error — the system was unable to close an output 
file. 

CO Call stack Overflow — insufficient memory available to 
transfer varable address' and/or return location for a 
subroutine call. 

ME Make error — the system was unable to make an output 
file on the disk. 

NF No file — an input file with the given name could cot 
be opened. 

OE Open Error — attempt to open a file which was already 
open . 

OP Open Error — the system was unable to open a file. 

PS Procedure Stack — cot enough memory to load all 

subrout ines . 

SO Subroutine Overflow — subroutine symbol table overflow. 

W1 Write non-sequential — attempted to WRITE to a file 
opened for INPUT or a file opened for 1-0 when ACCESS 
was SEQUENTIAL. 

W2 Wrong key — attempted to change the key value to a 
lower value than the number of the last record writ- 
ten. 
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W3 Write input — attempted to WRITE to a file opened 
for INPUT. 

W 4: Write non-empty — attempted to WRITE to a non-empty 

record . 

W5 Read output — attempted to READ a file opened for 
OUTPUT. 

W6 Rewrite error — attempted to REWRITE to a file 
not opened for I-O. 

W? Rewrite error — attempted to REWRITE a record before 
reading the file? or multiple REWRITE attempts with- 
out doing a READ between each. 

D. INTERPRETER WARNING MESSAGES 

EM End mark — a record that was read did not have a 

carriage return or a line feed in the expected location. 

GD Go to depending — the value of the depending indicator 
was greater than the number of available branch 
addresses . 

IC Invalid character — an invalid character was loaded 

into an output field during an edited move. For example, 
a numeric character into an alphabetic-only 
field. 

NE Numeric Error — non-numeric data in an arithmetic 
operation . 
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W8 Write Error — the system was unable to write to an 
output file on the disk. Disk may be full. 

SI Sign Invalid — the sign is not a or a 



156 



APPENDIX B 



LIST OF MICRO-COBOL RESERVED WORDS 



The 


following 


is a list 


of reserved 


words 


for 


MICRO-COBOL. The reserved words 


are the same 


as 


those 


specified 


for the 


HYPO-COBOL la 


nguage, except 


where noted 



with an asterisk (*). 



ACCEPT 


END- IF * 


MODE 


ROUNDED 


ACCESS 


ENTER 


MOVE 


RUN 


ADD 


ENVIRONMENT 


MULTIPLY 


SAME 


ADVANCING 


EOF * 


NEXT 


SECTION 


AFTEP 


EQUAL 


NO * 


SECURITY 


ALPHABETIC 


ERROR 


NOT 


SELECT 


AND * 


EXIT 


NUMERIC 


SENTENCE 


ASSIGN 


FD 


OBJECT-COMPUTER 


SEPARATE 


AUTHOR 


FILE 


OCCURS 


SEQUENTIAL 


BEFORE 


FILE-CONTROL 


OF 


SIGN 


BLOCK 


FILLER 


OMITTED 


SIZE 


BY 


FROM 


OPEN 


SOURCE-COMPUTER 


CALL 


GIVING * 


OR * 


SPACE 


CLOSE 


GO 


ORGANIZATION 


STANDARD 


COBOL 


GREATER 


OUTPUT 


STOP 


COMP 


1-0 


PAGE 


SUBTRACT 


COMP-3 * 


I-O-CONTROL 


PERFORM 


SYNC 


COMPUTATIONAL*! DENT I FI CAT I ON 


PIC 


THRU 


COMPUTE * 


IF 


PROCEDURE 


TIMES 


CONFIGURATION 


INDEXED * 


PROGRAM 


TO 


DATA 


INPUT 


PROGRAM-ID 


TRAILING 


DATE-WRITTEN 


INPUT-OUTPUT 


QUOTE 


UNTIL 


DEBUGGING 


INSTALLATION * 


RANDOM 


USAGE 


DELETE 


INVALID 


READ 


USING 


DEPENDING 


INTO * 


RECORD 


VALUE 


DISPLAY 


LABEL 


RECORDS 


VARYING * 


DIVIDE 


LEADING 


REDEFINES 


WITH * 


DIVISION 


LEFT 


RELATIVE 


WORKING-STORAGE 


ELSE 


LESS 


REWRITE 


WRITE 


END 


LINKAGE 


RIGHT 


ZERO 



In addition the arithemetic operat ors (> " "/” and 
** , and the comparison operators and "= are in 

the reserved word list. None of these symbols are in in HYP0 
COBOL but have been added to the grammar of NPS MICRO-COBOL 



15 ? 



to enable greater flexlblity 
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APPENDIX C 



The MICR0-C030L compiler and interpreter source files 
currently exist in the high level language PLMS0 and are 
edited and compiled under the ISIS operating system on a 
INTEL Corporation MDS system. This is a description of the 
procedures required to compile and establish the programs to 
compile and interpret a MICRO-COBOL program. The MICRO-COBCL 
compiler/interpreter runs on any 8080 or Z-80 based 
microcomputer that operates under CP/M. The execution of the 
following four files will cause a MICRO-COBOL program to be 
compiled and executed: 

1. COBOL.COM 

2. PART2.COM 

3. EXEC.COM 

4. CINTERP.COM 

These four files are created from the following six 
PLM80 source programs. 

1. PARTI. PLM 

2. PART2.PLM 

3. BUILD. PLM 

4. READER. PLM 

5. INTRDR.PLM 

6. INTERP.PLM 



159 



The procedures used to create the four object files (COM 
files) involve compiling, linking, and locating each of the 
six source files under ISIS. The SID program is then used 
under CP/M to construct the executable files. Each of the 
following steps describe the action(s) to be taken and, 
where appropriate, the command string to be entered into the 
computer . 

1. An ISIS system disk containing the PLK80 compiler is 
placed into drive A and a non-system disk containing the 
source programs is placed into drive 3. It should be noted 
that drive A and B are the CP/M reference names for the 
drives while FI and F2 are the ISIS reference names used for 
the associated disk drives. 

2. Compile the PLM source program under ISIS using the 
the following command: 

PLM80 :F1 :<f ilename> .PLM DEBUG XREF 



DEBUG saves the symbol table and line files for later 
use during debugging sessions. XREF causes a cross-reference 
listing, of all identifiers in the source program, to be 
created. The cross-reference listing includes each 
identifier and the associated line number where the 
identifier was declared and the line number of each 
occurence of the identifier in the source program [12] . 

3. Lick the PLM80 object file. 
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LINK : FI : <f i lename>.OBJ , TR I NT .OBJ , PLMS0.LIB, TO 
:F1 : <f ilename>.MOD 



See reference 11 for an explanation of PLM80.LIB. The 
TRINT.OBJ program interfaces the MON1 and M0N2 functions of 
CP/M to the source program, allowing for the use of absolute 
addresses in referencing these functions. 

4. Locate the object file. 

LOCATE :F1 : <f ilename>.MOD CODE(org address) 

The "org address" is the address where the prograr will 
begin to be loaded into memory. The following are org 
addresses" for the associated program: 



PARTI. MOD 


103E 


PART2 .MOD 


103E 


I NTERP .MOD 


103H 


INTRDR. MOD 


80S 


BUILD. MOD 


103E 


READER. MOD 


0B000E 



The org addresses" above represent the ones used with a 62K 
byte CP/M system. The only address that would need to be 
changed if a different size system was used would be the one 
for IREADER. MOD. See appendix E for specifics on the address 
to use for IREADER. 

4a. The two files INTRDR and IREADER just created by the 
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LOCATE command must be converted to "HEX FILES". By using 
the ISIS command OBJHEX <filename> the file will he 
converted to the "HEX file" <f ilename>. HEX. 

5. Replace the ISIS system disk in drive A with a CP/M 
system disk and reboot the system. 

6. Transfer the located ISIS file from the ISIS disk on 
drive B to the CP/M disk on drive A. 

FROMISIS <filename> 

6a. When transfering the "HEX files" to the CP/M disk 
use the following: 

FROMISIS <f ilenameXHEX 

7. Convert the ISIS file to a CP/M executable form. 

OBJCPM <filename> 

7a. The "HEX files" are not coverted to a CP/M format, 
but are left in HEX format. 

7b. The file INTERP should be renamed to CINTERP using 
the command "REN CINTERP=INTERP" before the file is 
converted to CP/M executable form. This is nessacary because 
the ISIS operating system allows file names to be only six 
letters in length. When EXEC.COM is executed, the message 
'CINTERP.COM NOT FOUND" will be displayed if this step is 
not omitted. 

At this point the object file is in machine readable 
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form and will run under CP/M when called properly. PART2.COM 
and CINTERP.COM are called by PART1.COM (COBOI.COM) and 
BUILD.COM (EXEC.COM), respectively and need no further work. 
COBOL.COM and EXEC.COM need to be constructed from the 
remaining four files. 

COBOL.COM is created by entering the following commands: 

1. SID PART1.COM 

2. IREADSR . HEX 

3. R8600 

4. A314A 

5. JMP 0B000 

6. Control-C 

7. Save 56 COBOL.COM 

See reference 7 for an explanation of the "i", "r", and 
"a” commands used above and ref 5 for an explanation of the 
"SAVE” command. Steps four and five above are used to patch 
the JUMP to READER referred to in the PARTI. PLM program into 
the PART1.COM program. It should be noted that each time 
PART ONE is changed and recompiled the address of the 
"patch" instruction (step 4 above) will change. Use of the L 
command will aid in locating the address that needs to be 
changed. The assembly language code will have the following 
form: 314A JMP 314A. 

EXEC.COM is created by entering the following commands: 
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1. SID BUILD. COM 

2. IINTRDR.HEX 

3. R1C00 

4. CONTROL-C 

5. SAVE 31 EXEC.COM 



NPS MICRO-COBOL programs may now be executed in the 
following manner. The source program is named, 

<filename> .CBL. The command "COBOL <? ilename>", causes the 
MICRO-COBOL source program to be read into memory and 
compiled. During the compilation, the intermediate code 
file, <f ilename>. CIN , is written out to the disk as the code 
is generated. The command "EXEC <filename>", causes the 
file, <f ilename> .CIN , to be executed. 
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APPENDIX D 



PART ONE AND PART TWO INTERNAL DATA STRUCTURES 
AND SIGNIFICANT VARIABLES 

Within PART ONE and PART TWO, many significant data 
structures are used by the procedures which constitute tne 
scanner and parser. Descriptions are given below for those 
structures regarded as important and necessary for future 
compiler development. 



1. Interfacing Structures 

ADD$END — this variable is used to hold the end cf file 
filler for the end of the source program. 

BUFFER(ll) — byte array used to hold the filename and 
filetype if declared, of an input or output file in the 
SELECT CLAUSE of the FILE SECTION of a KICRO-COBOL source 
program. 



BUFFER$END 
of the compiler 
for reading the 
ERR0R$CTR(5 



- address variable which marks the last byte 
input buffer which is a 128 byte buffer used 
source program. 

— byte array used to hold a count of the 



total number of errors. 

IN$ADDR — address variable, default file control block 
used initially to hold the <f ilename.CBL> of the source 
program to be compiled. 

IN$EUFF — literal value, marks the first byte cf the 
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compiler input buffer. 

I NPUT$FCB — byte value, based at IN$ADDR(33), the base 
address of the default file control block of the source 
program. 



LINE^CTR — byte value that keeps track 
lines in the input file. Also used to write 
to the list file. 

LIST$BUFF(128) — byte array, used as a 
buffer for loading the generated list file. 

LIST$FCE(33 ) ~ byte array for the 



of the number of 
the line numbers 

128 byte output 

list file, file 



control block. 

LIST$PTR — address value, used as an index into the 
list buffer ( LIST$BUFF) . 

OUTPUT$BUFF ( 128 ) — byte array, used as a 128 byte 
output buffer for loading the generated output (pseudo 
instructions) when writing to the intermediate code file. 

OUTPUT$CEAR — byte value, based at the OUTPUT$PTR> used 
to identify the particular byte of the output buffer 
( 0UTPUT$3UFF ) to which the next intermediate code 
instruction is to be written. 

OUTPUT$END — address variable, pointer to the end of 
the output buffer (OUTPUT$BUFF) . 

OUTPUT$FCB( 33 ) -- byte array, the FC3 for the 
intermediate code file <f ilename .CIN> established in PART 
ONE of the compiler and pasted to PART TWO of the compiler 
by IREADER module. 
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OUTPCT$PTR — address value, used as an index into the 
output buffer (OUTPUT$BUEE ) . 

POINTER — address value, the address of the byte 
holding the next input character of the source program. 

2. Debugging Structures 

DEBUGGING — logical byte value, toggle used in 
conjunction with in a MICRO-COBOL source program text; 
allows for the compilation or non-compilation of the 
deugging statements following the 

ERROR — logical byte value, toggle used to indicate an 
error condition and override a nolist condition thus 
allowing errors to be written to the list file reguardless 
of the write^lst toggle. 

LIST$INPUT — logical byte value, toggle used to display 
or not display a source program to the CRT during 
compilation. 

NO$CODE — logical byte value, toggle used to stop code 
generation for faster syntax checking. 

PARMLIST(9) — byte array used to hold the toggles set 
by the compiler developer or user upon execution of the 
command: COBOL <f ilename. CEL> $TOGGLES. 

PRINT$PROD — logical byte value, toggle used to print, 
in chronological order, at the CRT the production numbers of 
the compiler grammar rules used during a compilation of the 
source program. 
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PRINT$TOKEN — logical byte value, toggle used to print 
tokens and the numbers assigned to them. 

SEQ$NUM — logical byte value, toggle used to indicate 
the presence of sequence numbers in the first six positions 
of each line of a source program being compiled. 

WRITE$LST — logical byte value, toggle used to indicate 
whether a list file is to be generated. A limited list file 
containing errors and the line being parsed at the time of 
the error(s) is always created. 

UE$FLA0 — logical byte value, toggle used to indicate 
whether there is an undeclared varible. 

3. Memory Structures 

EOFEILLER — literal value, used to test for the 
occurrence of an end of file character ("lAE” in CP/M), when 
reading the source program. 

FREESSTORAGE — first free address following PART ONE of 
the compiler; utilized as the base of the symbol table. This 
is the same value as HASE$TAB$ADDR in PART TWO of the 
compiler . 

INITIAL$POS — address value, the initial location of 
the IREADER module before it is copied to high memory at 
location MAX$ MEMORY . 

MAX$MEMORY — address value, the location in high memory 
where the IREADER module is to be moved. 

MAX$ INT$ MEM — address value, the highest usable 
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addressable memory. This is the point where no more code can 
be generated due to insufficient memory. 

NEXT $ AVAILABLE — address value, the pseudo machine 
memory address for the next machine instruction. 

PART1$LEN — the number of bytes of information saved in 
high memory after execution of PART ONE and used to 
initialize PART TWO module variables of the compiler. 

PASS15TOP — this address is used in conjunction with 
PASS1$LEN for locating the fourty-eight bytes of information 
saved in PART ONE for use in PART TVO of the compiler. 

RDR$LENGTE — literal value representing the 255 bytes 
of the IREADER module to be moved from INITIAL$POS to 
MAX$M5K0RY. 



4. Scanner Structures: 



ACCUtf(51) — an array of 51 byt 
contains a count of the total number of c 
in the accumulator. This structure holds 
scanned, and will hold either a res 
defined identifier, or a literal. 

COLLISION — address varible, contai 
bytes of an identifier's symbol table 
whether there is another identifier which 
hash table address. This address points t 
address in the symbol table. 

DISPLAY(98) — an array of 74 bytes 



es; the first byte 
haracters currently 
tokens as they are 
erved word, a user 

ned in first two 
entry and indicates 
hashes to the same 
o that identifier's 

>' the first byte 
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contains a count of the total number of characters (1-73) 
currently in the display buffer. Every line within a source 
program is loaded into this structure for subsequent 
printing to the CRT terminal during compilation. 

EDI T^FLAG — logical flag which denotes the fact that a 
symbol has been loaded into the DISPLAY array during 
compilation. When set the characters within DISPLAY will be 
printed one at a time, until the entire line is printed. 

HASH$TABLE$ADDR — the base of the symbol table 
generated in PART ONE, used as the base of the hashtable. 

HASH$TAB$ADDR — this was the address of the bottom of 
the symbol table generated in PART ONE of the compiler, and 
saved for Part two. 

INPUT$STR — literal value (32), returned to the LALR(l) 
parser anytime the token contained in the ACCUM is not a 
reserved word or literal. 

LITERAL — literal value (15), returned to the LALR(l) 
parser anytime the first character encountered by the 
scanner is a quote ('), prior to loading the AC CUM. 

MAX$LEN — length of the longest reserved word allowed 
by MICRO-COBOL. 

5. Parser Structures: 

BUFFER(31) — byte array used to store edited PICTURE 
CLAUSE characters for subsequent intermediated code 
generati on. 
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COMPILING — logical byte value which indicates that 
compiling is taking place or not in PART ONE or PART TWO; 
set to FALSE whenever the statestack of the LALR(l) parser 
is reduced to a recognizable finished state. 

CUR$SYM — address variable that holds the address of 
the current symbol being accessed in the symbol table. 

DUP$IDEN$ARRAY (24) — address array that holds the 
symbol address for all files declared in the INPUT-OUTPUT 
SECTION of a source program. When the FILE SECTION entry for 
the file is encountered the array is searched to determine 
if the file was declared and to insure that a FILE SECTION 
entry had not been previously made. 

FILE$DESC$FLAG — logical byte value; indicates whether 
the compiler is compiling the FILE EESCRIPTION SECTION of a 
source program or not. 

FILE$SEC$END — logical byte value set whenever the 
parser has parsed passed the FILE SECTION of a source 
program . 

E0LD$LIT(51) — byte array, first byte contains a count 
of the total number of characters currently stored in the 
HOLDLIT buffer which is used to hold characters for a VALUE 
CLAUSE. 

ID$STACK(10) — address array which functions as a stack 
and is used to hold the addresses of identifiers at both the 
record and elementary levels. Whenever a record identifier 
has nested elementary field identifiers it is saved on the 
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ID$STACK. Also, anytime a record identifier has succeeding 
record identifiers redefining it, it is saved on the 
ID$STACK. In the case of multiple record descriptions in a 
file description of the FILE SECTION, the record 
descriptions following the first record are assumed 
redefinitions . 

ID$STACK$PTR — a byte index variable into the ID$STACK 
array. 

MAX$ID$LEN — a numeric value (12), maximum length of 
any user defined identifier. 

MP — byte index variable into the VALUE array. 

MPP1 — byte index variable into the VALUE array, one 
byte above M? index. 

NEXT$SYM — this address indicates the next available 
free space for a symbol table entry. 

PENDING$LITERAL — byte value ( 0 ,1 ,2 ,3 ,4, 5) , indicates 
the category of the target input to a VALUE CLAUSE. 

PENDINGiLIT $ID — byte value (0 , 1 ,2 ,3 , 4, 5 ) , which is 
saved to indicate the category of the most recently 
encountered target input to a VALUE CLAUSE. 

PRODUCTION — byte value, determined by the parser and 
indicates the next semantic action to be taken by the 
compiler . 

REDFF — logical byte value which allows the testing of 
an identifier's storage value size against the storage value 
size of a second identifier that redefines the first. Set to 
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TRUE when there are rrultlple record descriptions within a FD 
BLOCK in the FILE SECTION, or when a record or elementary- 
identifier declaration in the WORKING STORAGE SECTION 
contains a REDEFINES CLAUSE. 

REDEF$FLAG — logical byte value, used to denote the 
scanning and parsing of the FILE SECTION of a source 
program, helps in identifying duplicate identifiers within 
this section. 

REDEF$0NE — address variable that holds the symbol 
table address of the identifier being redefined by another 
identifier . 

REDEF$TW0 — an address variable that contains the 
symbol table address of an identifier which redefines 
another identifier. 

SP — a byte index for the STATESTACK array and the 
VALUE array? points to the top of the STATESTACK array. 

STATE — a byte value numeric quantity that indicates 
the current parser state. 

STATESTACK(40 ) — a byte array which stacks the states 
(production sequences) the parser passes through while 
compiling a source program. 

TRUNC$FLAG — logical byte value that indicates numeric 
truncation of an identifier's VALUE CLAUSE input hasn't 
occurred, because the identifier's associated PICTURE CLAUSE 
has not been scanned and parsed. 

V ALUE ( 40 ) — an address array that holds addresses of 
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identifiers, specific attributes of these identifiers and 
attributes of the current source program statement or 
sentence being parsed. 

VARC(51) — a byte array, the first byte holds the count 
of the total number of characters within it, used to hold 
all the ASCII characters of tokens scanned within the source 
program, excluding reserved words? for subsequent analysis 
and processing. 

VALUE^FLAG — a logical byte that is set anytime an 
identifier has an associated VALUE CLAUSE? used primarily to 
recognize the occurrence of a PICTURE CLAUSE before the 
VALUE CLAUSE or when a record entry has a VALUE CLAUSE, but 
no associated PICTURE CLAUSE except for those in its 
elementary field identifiers. 

VALUE^LEVEL — a byte value which saves the level number 
of a record identifier which doesn't have an associated 
PICTURE CLAUSE. 
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APPENDIX E 



MACHINE DEPENDENT VARIABLES 



The N PS MICRO-COBOL compiler/interpreter is designed to 
operate on an/ SOSO or Z83 based microcomputer operating 
under CP/M with at least 20K bytes of memory. The PLM80 
source files have been written in such a way, that certain 
variables must be altered in the source code to take 
advantage of the machine that the programs are going to be 
operating on. This appendix covers those programs and the 
variables that must be altered. 



1. PARTI. PLM 

This program has two variables that are memory size 
dependent, MAXiMEMORI and MAX$ I NT $ MEMORY . The variable 
MAX$MEMORY is set to 100H bytes below the base of the BDOS 
and is used for the beginning address of the IREADER 
routine. The variable MAX$INT$MEMORY is set to the base 
address of the BDOS and is used as the upper lirit for the 
intermediate code file. 



2. PART2.PLM 

This program also has two variables that are memory size 
dependent, MAX$MEMORY and PASS1$T0P. In this program 
MAX$MEMORY is set to the base address of the BDOS while 
PASS1$T0P is set to 100H bytes below the base of the BDOS. 

3. READER .PLM 



Although, this program does not have any memory size 
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dependent variables the program trust be modified to execute 
properly. When using the LOCATE command, under ISIS, this 
routine must be located 130E bytes below the BDOS of the 
system. This address would correspond to the values of 
MAXiMEMORT in PART2.PLM and MAX$INT$MEMORT in PART1.PLM. 

4. BUILD. PLM 

This program has one memory size dependent variable, 
I NTERP$ADDRESS must be set to the same address as CODE$START 
in I NTERP .PLM . 

5. INTERP.PLM and INTRDR.PLM 

These two programs have no variables that need to be 
altered . 

6. GENERAL INFORMATION 

The current version of the NPS MICRO-COBOL 

compiler/interpreter is designed for continued development 
and certain variables are not set to make optimal use of 
memory. The variable NEXT$AVAILABLE , in PARTI. PLM, is set to 
3502H and CODE $START , in INTERP.PLM, is set to 3500H. 
Normally, CCDE$START would be set to the address immediately 
following the last address in CINTERP.COM and NEXTiA VAI LABLE 
would be set two bytes above that address. These address are 
currently set approximately 450H bytes above where they 
should be located, to allow for testing ana expansion of the 
interpreter. As soon as implementation is completed these 
two addresses can be reset to appropriate values. 
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APPENDIX F 



MICRO-COBOL PARSE TABLE GENERATION 



The 


parse 


tables for 


N PS 


Mi c ro-Cobol 


were generated on 


the IBM 


360 


using the 


LALR(l) parse 


table 


generater 


described 


in 


reference 


20. 


There are basically 


two steps 



involved in generating the tables. First, a deck of cards 
containing the grammar is entered into the computer using 
the following JCL: 

//PROGNAME JOB (2320 ,041?, CS91 ), 'optional data',TIME=5 
//GO EXEC PGM= LALR , REGION =220 K 
//STEPLIB DD DSN=F0119.LALR,UNIT=2314, 

VOL=SER=LINDA ,DISP=SER 
//SYSPRINT DD SYSOUT=A,DCB=(RECFM=FB , 

LRECL=133 ,BLXSIZE=3325) , 

// SPACE=(C YL , (1,1) ) 

//N CNTER M DD SPACE= ( CYL , ( 1 , 1 ) ) ,UN IT=S YSDA 
//FSMDATA DD SPACE= (CYL , (1 ,1 ) ) ,UN IT=SYSDA 
* //PTABLES DD SYSOUT=B, 

DCB=(RECFM=FB , LRECL=80 ,BLKS IZE=800 ) 

//SYSIN DD * 

* This card can be replaced by //PTABLES DD SYSOUT=DUMMY 
to surpress the card punching feature. This allows 
modifications to be made without wasting cards until 
a new LALR(l) grammer is produced. 
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The ouput from this run is a listing and a card deck 
containing the tables in XPL compatable format. This deck is 
then translated into PLM compatible format using the 
following JCL and an XPL program which is available in the 
card deck library in the Computer Science Department at the 
Naval Postgraduate School. 

//EXEC XCOM 
//COMP .SYSIN DD * 

//GO .STSPUNC H DD SYSOUT=B, 

DCE=(RECFM=FE ,LRECL=80 ,BLKS I ZE=800) 

//GO. SYSIN DD * 

The tables are then transferred to a diskette and edited 
into the PLM80 source program using the ISIS COPY ar.d EDIT 
features on the INTEL MDS System. See APPENDIX H for the 
procedures to transfer files from the IBM-360 to a floppy 
diskette . 
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APPENDIX G 



LIST OF INOPERATIVE CONSTRUCTS 

The following is a list of MICRO-COBOL elements that 
either have not been implemented. 

CLOSE - multiple closes 

OPEN - multiple open's 

The following 5TP0-C0B0L elements are part of NPS 
MICRO-COBOL only to the extent that they are defined in the 
grammar. No code has been written to support them. 

COMPUTE 

AND and OR 

ENTER 

COMP and COMPUTATIONAL (binary arithmetic storage and 
operati ons ) 

INDEXED 

MULTI-DIMENSION tables 
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APPENDIX H 



IBM TO MICROCOMPUTER TRANSFER PROCEDURES 

A CP/M operating system program was written by Prof. 
Kodres for the express purpose of transferring ASCII files 
from the IEM CP/CMS system. In order to use this program, 
several equipment requirements must be met: a.) Reserve the 
appropriate Intel MDS system in the Microcomputer Lab. b.) 
Call 646-2721 (computer-center ) to reserve a high speed(1200 
baud) line to the micro-lab. c.) Connect the line marked 
"IBM 1200 BAUD" line to the "black box" marked IBM, which 
contains line drivers for the P.S-232 circuit. Check that the 
toggle switch is in the up/raised position, d.) Connect the 
serial connector coming off the MODIFIED single board 
computer (marked with a yellow dot) to the other end of the 
line driver box. All of the other boards in the MDS are 
unmodified with the exception of times when hardware 
experimentation is being conducted by various groups of 
students and/or facalty. 

To commence communication with the 360 - invoke the CP/M 
program IBM.COM - an executible file. The program is loaded 
and executed by typing "IBM f ilename . f iletype" , where 
"filename. filetype" is selected by the user as the CP/M file 
which will be created as a result of a file transfer. 
Successful completion of the above steps will result in the 
following data being displayed on the CRT: 
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(crt echo? y/n) 
(n) 



Answer ”y" 

Placed by the CP/M program 
Enter a <CR> 

caCP-67 Online Normal CP/CMS signon message 

At this point login to CP/CMS in a normal manner. Files 
are transfered using the CMS command "PRINT” followed by the 
name of the file to be transfered followed by a control-R. 
This will cause the MDS to be put into the receive mode. A 
<CR> will start the file transfer. The CRT should display 



the 


following for a successful 


file 


tra 


nsf er. 


PRINT cmsfilename cmsfiletype 


Enter 


a 


control-P. 


(R) 




Puts 


MDS 


in receive mode 


(R. 


CREATED filename. filetype) 


Enter 


a 


<CR> 


( — 


— bytes received END R) 


Enter 


a 


<CR> to re-enter CP 






Enter 


a 


control-C to reboot 



Each file transfer must be done wi 
invocation of the IBM file as all files will 
to the file named when I3M is invoked. Befor 
the last time logout of CP/CMS in the normal 
2721 and inform the computer center that the 
is available for other user's. 



th 


a seDa 


ra 


te 


be 


transfer 


ed 


e re 


booting 


f 


or 


mann 


er and 


ca 


11 


high 


speed 


li 


ne 
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APPENDIX I 



DEBUGGING NPS MICRO-COBOL USING SID 

Note: Steps two and three are optional. They are used if 
the line numbers in the program listing are to be 
used as well as the symbols for pass points. 

PART ONE. 

1. SID COBOL.COM PARTI. SYM 

2. I* PARTI. LIN 

3. R <ret> 

4. Kfile name.C3L> Kcompilier toggles as required> 

5. Set desired passpoints 

PART TWO. 

1. SID COBOL.COM PART2.SYM 

2. I* PART2.LIN 

3. R<ret> 

4. Kfile name.CBL> $<compilier toggles as required> 

5. T50 

6. G 1 0B000 

7. T50 

8. G v 100 

9. Set desired passpoints 



182 



INTERPRETER. Note: Use only STM or LIN files but not both 



1. SID EXEC.COM CINTERP .STM 

2. I* CINTERP. LIN 

3. R<ret> 

4. Kfile name .C IN> 

5. G,22E 

6. T25 

?. G , 100 

8. Set desired passpoints 

These instructions are designed to get the programs to the 
proper place to be able to use SID. See reference [8] for 
instructions on how to use SID commands. It should be noted 
that changes to the routine BUILD will change instruction 5 
in the INTERPRETER command list. That command is intended to 
stop after BUILD has finished executing and is the location 
of the last instruction in that module. 
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COMPUTER LISTING EOF. MODULE PART ONE NPS MICRO-COBOL 



$ TITLE ( 'N PS MICRO-COBOL COMPILER PARTI') PAC-EWIDTE( 80 ) 
PAGELENGTH ( 60 ) 

PARTI : DO? 



/* 


COBOL COMPILER - 


PART 1 


*/ 


/* 


NORMALLY LOCATED 


AT 103H 


*/ 



/* GLOBAL DECLARATIONS AND LITERALS */ 



DECLARE DC L LITERALLY 'DECLARE', 

LIT LITERALLY 'LITERALLY'; 



DCL CR 


LIT 


'13' , 


EOFFILLER 


LIT 


'1AH ' , /* END OF 


FALSE 


LIT 


'0\ 


ERROR 


BYTE 


INITIAL(FALSE) , 


FILE$DESC$FLAG 


BYTE 


I N ITIAL (FALSE ) , 


UI$7LAG 


BYTE, 


/^UNDECLARED VAR 


FOREVER 


LIT 


'WHILE TRUE', 


INITIAL$POS 


ADDRESS 


INITIAL(3600H ) , 


LF 


LIT 


'10', 


MAX$MEMORY 


ADDRESS 


INITIAL(0B000E) , 


QUOTE 


LIT 


'27H ' , 


PARMLIST ( 9) 


BYTE 


I N ITIAL ( ' 


PAR MS 


LIT 


'6DH' , 


PASS1$LEN 


ADDRESS 


INITIAL (353 ) , 


POUND 


LIT 


'23H ' , 


PROC 


LIT 


'PROCEDURE', 


RDR$LENGTH 


LIT 


'255', 


TRUE 


LIT 


'l'j 



RECORD FILLER */ 



FLAG*/ 



9 



MAXLNO 


LITERALLY 


'138' , 


/* 


MAX LOOK COUNT 


*/ 


MAXPNO 


LITERALLY 


'156', 


/* 


MAX FUSE COUNT 


*/ 


MAXRNO 


LITERALLY 


'110', 


/* 


MAX READ COUNT 


*/ 


MAXSNO 


LITERALLY 


'253', 


/* 


MAX STATE COUNT */ 


STARTS 


LITERALLY 


'1\ 


/* 


START STATE */ 




PRODNO 


LITERALLY 


'97', 


/* 


NUMBER OF PRODUCTIONS */ 


PROCC 


LITERALLY 


'48', 


r- 


* PROCEDURE */ 




TERMNO 


LITERALLY 


'64'; 


/* 


TERMINAL COUNT 


*/ 



DCL READ1 (*) BYTE 

DATA (0,61 ,50,60,33,8,25,63,2 ,33,55,62,11,33,33,41,40.36 
,46,9,19,39,6,26,34,59,3,14,15,18,20,33,29,51 ,33,1 ,44,40 
,38,45,1 ,1,1 ,1,1, 1,1, 1,1 ,10,1 ,41,1,1,1,40,1,35,42,51,40 
,41,1,1,40,16,17,22,30,23,24,58,54,57,43,37,48,1,7,52,1 
,33,1,33,33,47,1 ,33,1,33,1,33,1,33,49,27,33,39,4,35,56 
,42,1,1 ,33,5,12,13,21,22,28,1 ,64,1 ,23,24,58,31,53) J 



ie4 



DCL L00K1(*) BYTE 

DATA (0,8, 0,25, 0,9, 19, 0,44, 0,44, 0,1, 0,54,0 ,57,0,43,0,37,0 
,52,0,1 ,0,49,0,4,0,35,0,56,0,42,0,1 ,0,2,0 ,33,0,1 ,0,1 ,0,11 
,0,64,0,7,0,33,0,33,0,33,0); 

DCL APPLYK*) BYTE 

TATA( 0,0, 0,0, 0,0, 0,0, 9, 10,12,14,16,20,0,0,0,0,0,0,107,0,0 
,106 ,0,0 ,0,0 ,0,0,103,0,28,0,0,0,0,98,0,0,0 ,96,0,0,0 ,0,13 
,18,0,108,109,110,0,0,0,0,0,101,0 ,0 ,56,0,0,24,31 ,39,40,0 
,22,41 ,42,54,58,90,99,100,0) ; 

DCL READ2 (*) BYTE 

DATA ( 0 ,68 ,59 , 67 , 1 68 , 27 , 38, 70 , 22 , 252 , 63 , 69 , 28 , 253 , 231 ,53 
.47,114,115,242,243,45,232,233 ,235,234,23,249,248,251 ,250 
,247,189,188,184,9,245,49,212,211 ,7 ,8 , 11 , 13 , 15 , 2 ,3 , 1 1 1 ,1 6 
,173,4,52,21,14,19,50,12,187,186,185,46,51,20,10,48,31,32 
,34,40,36 ,37,66,62,65,55,44,157,17,26,60,112,169 ,160,169 
,169,57,162 ,169,164,169,166,169,172 ,169,58,224,253,209 
,24,42,64,54,222,196,253,25,29,113,33,35,39,18,71,179,36 
,37,66,41,61); 

DCL L00K2(*) BYTE 

DATA (0 ,5,139,6,140,30,30,141 ,43,142,56,143,144,72,74,145 
,75,146,76,147,77,148,81 ,149,150,84,89,151 ,92,214,93,239 
,94,152,95,153,205,96,98,200,99,213 ,227,101,154,102,103 
,192,105,155,156,107, 106,216,109,216,110,204) J 
DCL APPLY2(*) BYTE 

DATA( 0,0, 121 ,158,118,117,119,159,83,122,85,86,87,88,82,80 
,126,79,170 ,135,178,177,106,181,180,182,127,163,175,133 
,195,194,100,130,78,134,129,203,202 ,104,128,208,207,210 
,120,199,137,138,136,221 ,221 , 221 , 220 , 1 23 , 132 , 97 , 131 , 230 
,229,240,237 ,236 ,241 , 215 ,9 1 , 125 , 124 , 90 , 11 6 , 73 , 238 , 190 , 225 
,223,198,198,197); 

DCL INDEXl(-) BYTE 

DATA (0,1 ,2,3,4,5,6,7,8,4,4,9,4,9,4,10,4,11,9,117 ,4,12,13 
,13,9,14,15 ,16,13,17,19,9,21,22.26,27,32,34,35,9,9,13,13 
,36,37,38,40,41 ,42,43,44,45,46 ,47,13,48,36,49,13 ,50,51 ,52 
,53,54,55,56,57,60,61,62,63,64,65,69,72,73,74,75,76,77 ,78 



,79,80,82,84,86,88,90,92,94,95,97,98,99,100,101,65,102 ,8 
,13,103,105 ,105,12,111,112,113.117,9,9,9,1 ,3,5,8 ,10,12 



,14,16,18,20,22,24,26,28,30,32,34,36,38,40,42,44,46,48,50 
,52,54 ,56 ,201,161 ,244,246,246,206,165,163,167,219,171 ,174 
,226,176,191 ,228,217,193,1 ,2,3 ,4,4,5,5,6,6,7,7,8,8,15,15 
,16,17,17 ,18,18,19,19,20,22,22,23,23,23,25,25,25,26,26,27 
,27,28,28,29,29,30,32,32,34,35,35,36,36,37,39,39,40,40,41 
,41 ,41 ,41 ,41 ,43,43,44,44,45,45,46,46,49,53,53,54,54,55 ,55 
, 56 , 56 , 57 , 57 , 57 , 57 , 57 , 57 , 57 , 57 ,57 ,57 , 57 ,59 , 59 , 59 , 60 , 60 ,62 
,62,62,62,62,63,68); 

DCL I NDEX2 ( * ) BYTE 

DATA (0,1, 1,1, 1,1, 1,1, 1,1, 1,1, 1,1, 1,1, 1,1, 1,1, 1,1, 1,1,1 ,1 



f 

t 

9 

9 



1.1. 1.2. 2. 1.1. 4. 1.5. 2. 1.1. 1.1. 1.1. 1.1. 2. 1.1. 1.1. 1.1 

1.1.1 ,1,1 *1,1, 1,1, 1,1, 1,3, 1,1, 1,1, 1,4, 3, 1,1, 1,1 ,1,1 

2. 2. 2. 2. 2. 2. 2. 1.2. 1.1. 1.1. 1.4. 1.1. 1.2. 6. 6. 1.1. 1.4. 2 

1 . 2 . 2 . 3 . 2 . 2 . 2 . 2 . 2 . 2 . 2 . 2 . 2 . 2 . 2 . 2 . 2 . 2 . 2 . 2 . 2 . 2 . 2 . 2 . 2. 2 



» 
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,2,5,6 ,30 ,43,56,72,74,75,76,77,81 ,84,89,94,95,102,105,107 
,3, 7, 3, 3, 0,3, 0,3, 0,3, 0,0, 1,7, 0,8, 1,0, 6, 0,0, 1,3, 0,1,1, 2,1 
,0,0, 0,0, 0,1, 0,2, 0,0, 1,2, 0,1, 5, 3, 0,0, 1,4, 0,0, 0,1, 2, 1,2, 2 
,2, 0,2, 3,0,3, 0,0, 1,4, 0,0, 1,0, 0,0, 0,1,1 ,1,1 ,1,1, 2,2, 3,1 ,1 
, 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ); 



/* JOINT DECLARATIONS 

THESE ITEMS ARE DECLARED TOGETHER IN THIS SECTION 
IN ORDER TO FACILITATE THEIR BEING SAVED FOR 



THE SECOND PART OF THE COMPILER. */ 



DEBUGGING 


BYTE 


IN ITIAL(FALSE) , 


ERROR$CTR (5 ) 


BYTE 


INITIALS 0'), 


LI NE$CTR (5) 
LIST$BUFF(128) 
LI ST$FCB ( 33 ) 
,0), 

LIST$ I NPUT 


BYTE, 

BYTE, 

BYTE 


INITIALS, ' 


BYTE 


I NITIAL( TRUE ) , 


LI ST$PTR 


ADDRESS, 




MAX$INT£MEM 


ADDRESS 


I N ITIAL (0B 100 ) , 


NEXT$AVAILABLE 


ADDRESS 


IN ITIAL(3502H) , 


NEXT$SYM 


ADDRESS , 




NO$CODE 


BYTE 


INITIAL(FALSE) , 


OUTPUT$BUFF (128) 
CUTPUT$FCB ( 33 ) 

,0), 

OUTPUT$PTR 


BYTE, 

BYTE 


INITIAL(0, ' 


ADDRESS , 




POINTER 


ADDRESS 


INITIAL( 100E) , 


PRI NT$ PROD 


BYTE 


IN ITI AL (FALSE ) , 


PRI NT$TOKEN 


BYTE 


INITIAL(FALSE) , 


SE0$NUM 


BYTE 


INITIAL(FALSE) , 


WRITES 1ST 


BYTE 


IN ITIAL (FALSE) , 


FREE$STORAGE 


ADDRESS 


INITIAL(3800H) , 


FILE$SECSEND 


BYTE 


IN ITIAL( FALSE) , 



LST' ,0,0,0 



CIN',0 ,0 ,0 



/* I 0 BUFFERS AND GLOBALS */ 



IN$ADDR 


ADDRESS INITIAL(5CH) , 


I NPUT$FCB 


BASED I N$ADDR (33 ) BYTE, 


LIST$CHAR 


BASED LISTSPTR BYTE, 


LIST$END 


ADDRESS, 


OUTPUT $CEAR 


BASED OUTPUT$PTR BYTE, 


OUTPUT$END 


address; 


MON 1 : PROC ( F , A ) 


external; 


DCL A ADDRESS 


, f byte; 


END MONi; 




M0N2: PROC (F,A) 


BYTE EXTERNAL; 


DCL F BYTE, A 


address; 


END M0N2; 





BOOT: PROC EXTERNAL; 
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END BOOT; 



PRINT$CEAR: PROC (CHAR). 

DCL CHAR BYTE! 

CALL MON 1 (2, CHAR); 

END printcear; 

WRI TE$OUTPUT : PROC (BUFF ,FCB ) 5 /* WRITES OUT A BUFFER */ 

DCL ( BUFF ,FCB ) ADDRESS; 

CALL MON 1 (26 ,BUFF ) * /* SET DMA */ 

IF M0N2 (21 , FCB ) <> 0 TEEN 

do; 

CALL MON1 (9, . ( 'WR$') ) ; 

CALL boot; 

end; 

CALL MON1(26,80E); /* RESET DMA */ 

END WRITE$OUTPUT ; 

WRI TE$TO$D ISK : PROC(CHAR); 

DCL CHAR BYTE; 

IF ( LIST$PTR := LIST$PTR + l) > LlSTiEND THEN 

do; 

CALL WR I TE$OUTPUT( .LI ST$3UFF, .LIST$FC5) J 
LIS T$PTP. = .listsbuff; 

end; 

LIST$CHAR = CHAR; 

end write$to$disk; 

PRINT: PROC (A); 

DCL (A, ADDR) ADDRESS f CHAR BASED ADDR BYTE? 

ADDR = A; 

DO WHILE CHAR <> '$'; 

CALL WR ITE$TO$DI SK ( CHAR ) J 
ADDR = ADDR + 1J 

end; 

CALL MON1 (9, A); 

END print; 

CRLFrPROC; 

CALL MON1 (9, . (CR,LF, '$')); 

END crlf; 

DCRLF: PROC; 

CALL WRITE$TO$DISK(CR); 

CALL WRITE^TO$DISK(LF) ; 

END DCRLF; 

INC$CTR: PROC (BASE) 5 

DCL BASE ADDRESS, CTR BYTE, B$BYTE BASED BASE (1) BYTE, 
TEN LIT '3AH'; 

CTR = 4; 
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DO WHILE (3£BYTE( CTR ) := B$BYTE(CTR) + 1) = TEN ; 
B$BYTE(CTR) = '0'; 

IF CTR > 0 THEN 

IF 3$BYTE ( CTR := CTR - 1) = ' ' THEN 
B$BYTE ( CTR ) = '0'; 

END? 

END inc$ctr; 

PRINT$ERROR : PROC (CODE); 

DCL I BYTE, CODE ADDRESS , CODE1 ( 6 ) ADDRESS; 

IE CODE = FALSE THEN 

do; 

DO I = 0 TO 5; 

CODEl(I) = 0; 

end; 
i = 0 ; 

end; 

ELSE IF CODE = TRUE THEN 

do; 

i = 0 ; 

DO WHILE ( ( I <> 6) AND ( CODEl(I) <> 0)) 
CALL PRINTCHAR (HIGH (CODE1 ( I ) ) ) > 

CALL PRINTCHAP. (LOW (CODEl(I))); 

CALL WRITE$TO$DISK(HIGH (CODE1 ( I ) ))? 
CALL WRITE$TO$DISK( LOW ( CODE1 ( I ) ) ) 5 
CALL crlf; 

CALL dcrlf; 

CODE1 ( I ) = 0 ; 
i = i + i; 

end; 
i = 0 ; 

error = false; 

end; 

ELSE IF (CODE = 'NP') OR (CODE = 'SL') 

OR (CODE = 'NV') THEN 

do; 

ERROR = TRUE; 

CALL PRINTCHAR (HIGH ( CODE )) ; 

CALL PRINTCEAR(LOW(CODE) ); 

CALL INC$CTR( .EPROR$CTR(0 ) ) ; 

IF CODE <> 'NP' THEN 

do; 

call crle; 
call dcrlf; 

end; 

end; 

ELSE 

do; 

ERROR = TRUE; 

IF I <> 6 THEN 

do; 
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cornu ) = code; 

end; 

CALL INC$CTR( . ERROR $CTR(0 ) ) ; 

end; 

end print$error; 

FATAL$ERROR: PROC (REASON ) ; 

DCL REASON ADDRESS,* 

CALL PRI NT$ERROR ( REASON ) J 
CALL PRINTS ERROR (TRUE ) i 
CALL boot; 
end fatal$error; 

OPEN: PROC; 

IF M0N2 (15 t INHDDR) = 255 THEN CALL FA TAL$ ERROR ( 'OP ' ) J 
END open; 

MORE$I NPUT : PROC BYTE; 

DCL DCNT BYTE; 

IF (DCNT := M0N2 (20, . INPUT$?CB ) ) > 1 THEN 
CALL FATAL$ERROR( 'BR') ; 

RETURN NOT(DCNT); 

END more$input; 

MAKE: PROC(FCB); 

DCL FCB ADDRESS,* 

/* DELETES ANY EXISTING COPY 07 THE OUTPUT FILE 
AND CREATES A NEW COPY*/ 

CALL M0N1 (1 9, FCB ) ; 

IF M0N2 (22 , FCB ) = 255 THEN CALL FATAL$ERROR ( 'MA ' ) ; 

END make; 

MOVE: PROC (SOURCE, DESTINATION, COUNT); 

DCL (SOURCE, DESTINATION, COUNT) ADDRESS, 

( S$BYTE BASEL SOURCE, D $ BY T E BASED DESTINATION) BYTE; 

DO WHILE (COUNT := COUNT -1)0 0FFFFH,* 

D^BYTE = SSBYTE; 

SOURCE = SOURCE + l; 

DESTINATION = DESTINATION + i; 

end; 
end move; 

FILL: PROC(ADDR, CHAR, COUNT); 

DCL (ADDR, COUNT) ADDRESS, 

(CHAR ,DEST BASED ADDR) BYTE; 

DO WHILE (COUNT := COUNT - 1) <> 0FFFFHJ 
DEST = char; 

ADDR = ADDR + l; 

end; 

END fill; 
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# # £ #/ 





/if if if 


# # * 


SCANNER LITS * * * 


DCL 


I NPUT$ STR 


LIT 


'33' , 




LITERAL 


LIT 


'15', 




PERIOD 


LIT 


'i '; 




/if if if if if 


SCANNER 


TABLES * * * * */ 


DCL 


T0KEN$TA3LE 


(*) BYTE 


DATA 



/* CONTAINS THE TOKEN NUMBER ONE LESS THJN THE FIRST 
RESERVED WORD FOR EACH LENGTH OF WORD */ 

(0,0, 1 ,4,5, 15,22,33,40,46,49,51,53,58,60,61) . 

TABLE(*) BYTE DATA ( 'FD ', 'OF ', 'TO ', 'P IC 'COMP ' , 'DATA ', 'FILE ' 

, 'LEFT', 'MODE', 'SAME', 'SIGN', 'SYNC', 'ZERO', 'BLOCK' 

, 'LABEL', 'QUOTE', 'RIGHT', 'SPACE' , 'USAGE', 'VALUE' , 'ACCESS ' 
, 'ASSIGN ', 'AUTHOR', 'COMP-3', 'FILLER', 'OCCURS ', 'RANDOM ' 

, 'RECORD' , 'SELECT', 'DISPLAY' , 'INDEXED' , 'LEADING' 

, 'LINKAGE', 'OMITTED', 'RECORDS' , 'SECTION ', 'DI VI SI ON ' 

, 'RELATIVE', 'SECURITY', 'SEPARATE ', 'STANDARD ' , 'TRAILING' 

, 'DEBUGGING ' , 'PROCEDURE' , 'REDEFINES ' , 'PROGRAM-ID' 

, 'SEQUENTIAL', 'ENVIRONMENT' , 'I-O-CONTROL' , 'DATE-WRITTEN' 

, 'FILE-CONTROL ', 'INPUT-OUTPUT ',' INSTALLATION ' 

, 'ORGANIZATION ', 'COMPUTATIONAL' , 'CONFIGURATION ' 

, 'IDENTIFICATION', 'OBJECT-COMPUTER ', 'SOURCE-COMPUTER ' 

, 'WORKING-STORAGE') , 



OFFSET (16) ADDRESS 



/* NUMBER 


OF 


BYTES TO 


INDEX INTO THE TABLE FOR EACH 


LENGTH 


*/ 






INITIAL (0, 


0, 


0,6,9,45, 


80,134,183 ,231 ,258,278, 


300,360, 


366,400) , 




WORD$COUNT (*) 


BYTE DATA 




/* NUMBER OF 


WORDS OF 


EACH SIZE */ 


( 0 ? 0 1 3 f 1 , 9 f 


7, 


9, 7, 6, 3, 2 


*2, 5, 2, 1,3), 


ACCUM$ LEN $P$1 


LIT 


'51', /* ACCUM$LENG PLUS 1 


ACCUM (ACCUM$LEN$P$1) 


BYTE, 


ACCUMiLENG 




LIT 


'50' , 


ADD$END(*) 




BYTE 


DATA( ' PROCEDURE'), 


3UFFER$END 




ADDRESS 


I NI TI AL ( 100H ) , 


CHAR 




BYTE 


INITIAL ( CR ) , 


DISPLAY (88) 




BYTE 


INITIAL (5, ' 1 '), 


EIRST$LINE 




BYTE 


INITIAL (TRUE) , 


FORMFEED 




LIT 


'0CH', 


HOLD 




BYTE, 




INBUEF 




LIT 


'80H ' , 


LOOKED 




BYTE 


I NITIAL (FALSE ) , 


M>X$LEN 




LIT 


'15', 


NEXT 




BASED 


POINTER BYTE, 


TAB 




LIT 


'09', 



190 



TOKEN 



byte; 



/^RETURNED FROM SCANNER #/ 



/* * * * * PROCEDURES USED BY THE SCANNER * * * */ 

NEXT$CHAR: PROC BYTE? 

IF LOOKED THEN 

do; 

LOOKED = FALSE; 

RETURN (CHAR := HOLD); 

end; 

IF ( POINTER :=POINTER + 1 ) >= BUFFERSEND TEEN 
EO 5 

IF NOT MORE$IN PUT THEN 

do; 

BUFFER$END = .MEMORY; 

POINTER = .ADD$ENDJ 

end; 

ELSE POINTER = INBUFF; 

end; 

IF NEXT = EOFFILLER THEN 

do; 

BUFFER$EN D = .MEMORY; 

POINTER = ,ADD$ENDJ 

end; 

RETURN (CHAR := NEXT); 

END next$cear; 

GET$CEAR: PROC5 

char=next$char; 

END GETiCHARJ 

DISPLAY$LINE : PROC? 

DCL I byte; 

DO I = 1 TO DISPLAY ( 0 ) J 

IF LIST$ INPUT OR ERROR THEN CALL 
PRINTCHAR(DISPLAY( I ) ) ; 

IF WRITE$LST OR ERROR THEN 

CALL WRITE$TO$DISK ( DISPLAY ( I ) ) ; 

END? 

CALL I NC $CTR ( . DISPLAY ( 0 ) ) ; 

DISPLAY ( 0 ) = 5? 

END display$line; 

LOAD$DISPLAY : PROCJ 

IF DISPLAYS) < 87 THEN 

DI SPLAY (DISPLAY (0 ) := DISPLAY(0) + 1) = CHAR; 
CALL get$char; 

END LOAD$DISPLAYJ 

PUT: PROC? 

IF ACCUM(0) < ACCUM$LENG THEN 
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ACCUM( ACCUM (0 ) := ACCUM ( 0) + 1) = CHAR? 

CALL load$display; 

END put; 

EAT$LINE : PROC ; 

DO WHILE CHAP <> CRJ 
CALL LOAD$DISPLAY»* 

end; 

end eat$line; 

GET$NO$BLANK: PROCJ 
DCL I byte; 
do forever; 

IF (CHAR = ' ' OR CHAR = TAB) THEN CALL LOAD$ DISPLAY 
ELSE IF CHAR=CR THEN 

do; 

IF FIRST$LINE THEN 

do; 

FIRST$LI NE = FALSE; 

CALL get$char; 

end; 

ELSE 

do; 

call load$display; 
call load$display; 
call display$line; 
call print$error(true) ; 

end; 

do while char = cr; 
call load$display; 
call load$display; 
call display$line; 

end; 

IF SEQ$NUM THEN 

DO I = 1 TO 6J 

CALL loadsdisplay; 

end; 

IF CHAR = THEN CALL EAT$LINEJ 
ELSE IF CHAR = '/' THEN 

do; 

IF LIST $ INPUT THEN 

CALL PRINT$CHAR(F0RM$FEED) ; 

IF WRITE$LST THEN 

CALL WRlTE$TO$DISK(FORM$FEED) ; 

CALL eatline; 

end; 

ELSE IF CHAR = THEN 

do; 

IF NOT DEBUGGING THEN CALL EAT$LINSJ 
ELSE CALL LOAD$ DISPLAY ; 

end; 
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end; 

else return; 

end; /* END OF DO FOREVER */ 

END get$no$blank; 

SPACE: PROC BYTE? 

RETURN (CHAR = ' ' ) OR (CHAR = CR) OR (CHAR = TAB); 

END space; 

DELIMITER: PROC BYTE; 

IF CFAR <> THEN RETURN FALSE » 

HOLD = next$char; 

LOOKED = TRUE,* 

IF SPACE THEN 

do; 

char = ' . '; 

RETURN TRUE? 

end; 
char = 

RETURN FALSE; 

end delimiter; 

END$OF$TOKEN: PRCC BYTE; 

RETURN SPACE OR DELIMITER; 

END END$OF$TOKEN ; 

GET$LITERAL: PROC BYTE? 

CALL LOADED ISPLAY J 

DO forever; 

IF CEAH = QUOTE THEN 

do; 

call load$display; 

RETURN LITERAL; 

end; 
call put; 

end; 

end get$literal; 

LOOK$UP : PROC BYTE; 

DCL POINT ADDRESS, HERE BASED POINT(l) BYTE, I BYTE? 

MATCH: PROC BYTE; 

DCL J byte; 

DO J = 1 TO ACCUM(0); 

IF HERE ( J - 1) <> ACCUM(J) THEN RETURN FALSE; 

end; 

RETURN TRUE? 

end match; 

POINT = OFFSET (AC CUM ( 0 ) ) + .TABLE; 

DO I = 1 TO WORD$COUNT(ACCUM(0) ) J 
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IF MATCH THEN RETURN I; 

POINT = POINT + ACCUM(0); 

end; 

RETURN FALSE; 

END LOOK$UP; 

RESERVED$WORD : PROC BYTE; 

DCL (NUMB, VALUE) BYTE; 

IF ACCUM(0) > MAX$LEN THEN RETURN 0; 

IF (NUME := TOKEN $TABLE( ACCUM ( 0) ) ) = 0 THEN RETURN 0; 
IF (VALUE := LOOK$UP) = 0 THEN RETURN 0; 

RETURN (NUMB + VALUE) J 

END reserved$vord; 

GET$TOKEN: PROC BYTE? 

ACCUM ( 0 ) = 0; 

CALL get$no$blank; 

IF CHAR = QUOTE THEN RETURN GET$LITERAL; 

IF DELIMITER THEN 

do; 

call put; 

RETURN PERIOD; 

end; 

do forever; 
call put; 

IF END$OF$TOKEN THEN RETURN INPUT$STR; 

END; /* OF DO FOREVER */ 

END get$token; 

SCANNER: PROC*, 

DCL CHECK BYTE; 

do forever; 

IF (TOKEN := GET$TOKEN ) = INPUT$STR THEN 
IF (CHECK := RESERVED$WORD) <> 0 THEN 
TOKEN = CHECK,* 

IF TOKEN <> 0 THEN RETURN; 

CALL PRINT$ERROR ('SE'); 

DO WHILE NOT END$OF$TOKEN J 
CALL GET$CHARJ 

end; 

end; 

end scanner; 

PRINT$ACCUM: PROC; 

DCL I byte; 

DO I = 1 TO ACCUM(0); 

CALL PR IN T$ CHAR ( ACCUM ( I ) ) ; 

CALL WRITE$TO$DISK(ACCUM(I)); 

end; 

CALL crlf; 
call dcrlf; 
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end print$accum; 

PRINT$NUMBER: PROC(NUMB); 

DCL( NUMB , I ,CNT,K ) BITE, J(*) BITE DATA ( 100 , 10 ) J 
DO I = 0 TO 1 ; 

CNT = 0; 

DO WHILE NUMB >= ( K : = J(I))J 
NUMB=NUMB - K} 

CNT=CNT + l; 

end; 

CALL PRINTCHAR( '0' + CNT); 

end; 

CALL PRINTCHAR( '0' + NUMB); 

END print$number; 

INIT$SCANNER : PROC; 

DCL CON$CBL (*) BITE DATA ( 'C3L' ) , ( TEST FLAG , I ) BYTE; 

CALL MOVE (PARMS , . PARMLIST,8 ) i 
IF PARMLI ST ( 0 ) = '$' THEN 

do; 

i 1=0; 

DO WHILE (TESTFLAG := PARMLIST(I := 

IF TESTFLAG = 'L' THEN LIST$INPUT 
IF TESTFLAG = 'S ' THEN SEQ$NUM 
IF TESTFLAG = THEN PRINT$PROD 

IF TESTFLAG = 'T' THEN PRI NT$TOKEN 
IF TESTFLAG = 'C' THEN NO$CODE 
IF TESTFLAG = 'V' TEEN WRITE$LST 
IF TESTFLAG = 'D ' THEN DEBUGGING 

end; 
end; 

CALL MOVE( . CON $CBL , IN $ADDR + 9,3); 

CALL FILL ( I N$ADDR + 12,0,5); 

CALL open; 

IF NOT NO$CODE THEN 

do; 

CALL MOVE (IN A DDR, . OUTPUT$FCE ,9) » 

0UTPUT$FCB(32) = 0J 
OUTPUT $END = ( OUTPUT$PTR := .OUTPUT* BUFF - l) + 126 
CALL MAKE ( .OUTPUT$FCB ) ; 

end; 

CALL MOVE (INADDR, .LIST$FCB,9)» 

LI ST$FCB (32 ) = 0; 

LIST$END = (LIST$PTR := ,LIST$BUFE - 1) + 128; 

CALL MAKE ( . LIST$FCB) ; 

CALL GET$NO$BLANK; /* PRIME THE SCANNER */ 

CALL PRINT$ERROR ( FALSE) J 

CALL PRINT(.('NPS MICRO-COBOL COMPILER VERSION 2.0', 
CR,LF,LF, '$')); 

END init$scanner; 



i + l)) o ' '; 

= NOT list$input; 
= not seo$num; 

= not print$prod; 

= NOT PRINTS TOKEN 
= NOT NOiCODE; 

= NOT write$lst; 

= not debugging; 
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/* * * * END OF SCANNER PROCEDURES * * * */ 

/***** SYMBOL TABLE DECLARATIONS * * * */ 

DCL 



ADDR2 




LIT 


'4', 


CUR$SYM 




ADDRESS, 


/^SYMBOL BEING ACCESSED*/ 


D$CNT 




BYTE, 




DECIMAL 




LIT 


'11', 


DISPLACEMENT 




LIT 


;i4', 


EL$CNT 




LIT 


6', 


HASH$MASX 




LIT 


'3FH ' , 


LEVEL 




LIT 


'10', 


LOCATION 




LIT 


'2', 


MAX$ID$LEN 




LIT 


'15', 


N EXT$SYM$ENTRY 


BASED NEXT$SYM 


ADDRESS, 


OCCURS$PTR 




ADDRESS 


INITIALS), 


p$length 




LIT 


'3', 


REL$ID 




LIT 


'5', 


SAVE$ADDR 




ADDRESS, 




S ^LENGTH 




LIT 


'3', 


S $TYPE 




LIT 


'2', 


START$NAME 




LIT 


'13', /*1 LESS*/ 


SYMBOL 




BASED CUR$SYM( 1 ) 


BYTE, 


SYMBOL$ADDR 




BASED CUR$SYM ( 1 ) 


ADDRESS , 


TEMP$PTR 




ADDRESS, 




TEMP$ADDR 




BASED TEMP$PTR 


ADDRESS , 


TEMP$BYTE 




BASED TEMP$PTR 


eyte; 


aflt * 


* if 


TYPE LITERALS * 


if if. if if if if if / 


DCL 








COMP 


LIT 


'21',, 




GROUP 


LIT 


'6 , 




OCCURS$TYPE 


LIT 


'128', 




RANDOM 


LIT 


'3', 




REL$KEY 


LIT 


'25', 




REL$KEY$UR 


LIT 


'26', 




SEQUENTIAL 


LIT 


'1', 




SEO$RELATI VE 


LIT 


'2 , 




UR$MASK 


LIT 


'128', 




VARIABLE$LENG 


LIT 


'4'; 






* SYMBOL TABLE ROUTINES * * * */ 



INIT$SYMBOL: PROC? 

/* INITIALIZE HASH TABLE AND FIRST COLLISION FIFLD */ 
CALL FILL ( FREE $S TOR AGE, 0, 130) > 

NEXT$S YM = FREE$STORAGE + 1285 
NEXT$SYM$ENTRY = 0? 

END init$symbol; 
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GET$P$LENGTH : PROC BYTE; 

RETURN SYMBOL (P$LENGTH ) 5 

END get$p$length; 

SET$ADDRESS : PROC(ADDR); 

DCL ADDR ADDRESS; 

SYMBOL$ADDR (LOCATION) = ADDR J 
END SET$ADDRESS; 

GET$ADDRESS : PROC ADDRESS,* 

RETURN SYMBOL$ADDR (LOCATION ) J 
END GET$ADDRESSJ 

GET$TYPE: PROC BYTE? 

RETURN SYMBOL(S$TYPE) ,* 

END GET$TYPE*, 

SET$TYPE: PROC(TYPE); 

DCL TYPE BYTE? 

SYMBOL(S$TYPE) = TYPE; 

end set$type; 

OR$TYPE : PROC (TYPE) 5 
DCL TYPE BYTE; 

SYMBOL ( S$TYPE ) = TYPE OR GET$TYPE; 
END or$type; 

GET$LEVEL : PROC BYTE? 

RETURN SYMBOL(LEVEL) ; 

end get$level; 

SET$LEVEL: PROC (LVL) ; 

DCL LVL BYTE; 

SYMBOL(LEVEL) = LVLJ 

END set$level; 

GET$DEC IMAL: PROC BYTE? 

RETURN SYMBOL (DEC IMAL ) 5 

END get$decimal; 

SET$DECIMAL: PROC (DEC)J 
DCL DEC BYTE,* 

SYMBOL (DEC IMAL ) = DEC; 

END set$decimal; 

SET$S$LENGTH : PROC (HOW$LONG) ; 

DCL HOV$LONG ADDRESS; 
SYMBOL$ADDR(S$LENGTH) = HOW$LONGJ 

END set$s$length; 
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GET$S$LENGTH: PROC ADDRESS ? 

RETURN SYMBOL$ADDR(S$LENGTH); 

END get$s$length; 

SET$ADDR2: PROC (ADDR ) ? 

DCL ADDR ADDRESS? 

SYMBOL $ ADDR (A DDR2 ) = ADDR; 

END SET$ADDR2; 

SET$TBL$S I ZE : PROC(OCCUR); 

DCL OCCUR address; 

SYMBOL$ADDR(EL$CNT) = OCCUR? 

END SET$TBL$SIZEJ 

GET$TBL$S I ZE : PROC ADDRESS? 

RETURN SYMBOL$ADDR(EL$CNT) ? 

END GET$TBL$SIZE? 

SET$I 0$ADDRS : PROC? 

SYMBOL$ADDR (LOCATION ) = NEXT $SYM ? 

SAVE$ADDR = CUR$SYM? 

END SET$IO$ADDRS? 

GET$PREV$OCCURS :PROC ADDRESS? 

TEMP$PTR = CUR$S YM + STARTNAME + GET$P$LENGTH ? 

RETURN TEMP$ADDR? 

END GET$PREV$ OCCURS ? 

PROCESS $ OCCURS :PROC? 

TEMPiPTR = NEXT$SYM? 

NEXT$S YM = N EXT$S YM + 3; 

TEMP$ADDR = OCCURS$PTR? /-SET PTR TO PREVIOUS OCCURS-/ 
CALL OR$TYPE (OCCURS $TYPE)? 

TEMP$PTR = TEMP$PTR + 2? 

TEMPSBYTE = D$CNT? 

END PROCESS$OCCURS? 

/* # * * PARSER DECLARATIONS * * * */ 



DCL 

COMPILING 



BYTE 



INITIAL(TRUE) 



HOLD$LIT(ACCUM$LEN$P$l) BYTE, 



HOLD$SYM 
ID$STACK(10) 
I D$STACK$PTR 
INT 

(I,J,K) 

MP 

MPP1 

NOLOOK 

REDEE 

REDEF$ONE 

REDEF$TWO 



ADDRESS 

ADDRESS 

BYTE 

LIT 

BYTE, 

BYTE, 

BYTE, 

BYTE 

BYTE 

ADDRESS 

ADDRESS 



INITIALS) , 

IN ITIAL(0) , 

'67', /* INITIALIZE -/ 



INITIAL ( TRUE ) , 
IN IT IAL ( FALSE) , 



198 



PENDING$LITERAL 
PENDI NG$LI T$ ID 
PSTACKSIZE 
SCD 
SP 

STATE 

STATESTACK (PSTACKSIZE) 

TEMP$HOLD 

TEMP$TW 0 

TRUN C$FLAG 

VALUE (PSTACKS IZE ) 

VALUE$FLAG 

VALUE$LEVEL 

VARC (51 ) 



BYTE 



INITIAL(FALSE) 



ADDRESS 



LIT 

LIT 

BYTE 

BYTE 

BYTE, 



'40', /* SIZE OF STACKS */ 
'70', /* CODE START */ 
INITIAL ( 255 ) , 

IN IT IAL ( STARTS ) , 

/* SAVED STATES */ 



ADDRESS 

ADDRESS 

BYTE 

ADDRESS 



IN IT IAL(TRUE) , 

/* TEMP VALUES */ 

I N IT IAL ( FALSE) , 

IN ITIAL (0 ) , 

/*TEMP CHAR STORE-/ 



BYTE 

BYTE 

byte; 



/* * * * PARSER ROUTINES * * * * */ 

BYTE$OUT : PROC(ONE$BYTE) J 
DCL ONE$BYTE BYTE? 

IF NO$CODE THEN RETURN; 

IF ( OUTPUT$PTR := OUTPUT$PTR + 1) > OUTPUT$END THEN 
DO 

CALL WRI TE$OUTPUT( .OUTPUT$BUFF, .OUTPUT$FCB ) J 

output$ptr=.output$buff; 

end; 

OUTPUT$CHAR = ONE$BYTEJ 

END byte$out; 

STRI NG$OUT : PROC (ADDR, COUNT ) ; 

DCL (ADDR, I, COUNT) ADDRESS, CHAR BASED ADDR BYTE; 

DO I = 1 TO count; 

CALL BYTE$OUT ( CHAR ) J 
ADDR = ADDR+i; 

end; 

end string$out; 

ADDR$OUT : PROC(ADDR); 

DCL ADDR ADDRESS; 

CALL BYTE$OUT (LOW (ADDR ) ) ; 

CALL BYTE$OUT( HIGH (ADDR) ) J 

END addr$out; 

FILL$STRING: PROC (COUNT, CHAR) ; 

DCL (I, COUNT) ADDRESS, CHAR BYTE; 

DO I = 1 TO count; 

CALL BYTE$OUT (CHAR ) J 

end; 

end fill$string; 

START$INITIALIZE: PROC (ADDR , CNT ) ; 

DCL (ADDR, CNT) ADDRESS? 
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CALL BYTEOUT ( IN T ) J 
CALL ADDR$OUT(ADDR); 

CALL ADDR$OUT(CNT); 

END start$initialize; 

BUILD$SYMBOL: PROC(LEN); 

DCL LEN BITE, TEMP ADDRESS; 

TEMP = next$sym; 

IF (NEXT$SYM := .SYMBOL (LEN := LEN + DISPLACEMENT)) 

> MAX$MEMORI THEN CALL F AT AL$ ERROR ( 'ST'); 

CALL FILL ( TEMP, 0, LEN ); 

END build$symbol; 

MATCH: PROC ADDRESS; 

/# CHECKS AN IDENTIFIER TO SEE IF IT IS IN TEE SYMBOL 
TABLE. IF IT IS PRESENT, CUR$SYM IS SET FOR ACCESS. 
OTHERWISE A NEW ENTRY IS MADE AND THE PRINT NAME 
IS ENTERED. ALL NAMES ARE TRUNCATED TO MAX$I D$LEN*/ 

DCL POINT ADDRESS, COLLISION BASED POINT ADDRESS, 

(HOLD, I) byte; 

IF VARC(0 ) > MAX$ID$LEN 

THEN VARC (0 ) = MAX$ID$LEN; /* TRUNCATE IF REQUIRED */ 
HOLD = 0J 

DO I = 1 TO VARC(0); /* CALCULATE HASH CODE */ 

HOLD = HOLD + VARC ( I ) ? 

end; 

POINT = FREE$STORAGE + SEL((HOLD AND HASH$MASK ) , 1 ) J 
UI$FLAG = false; 
do forever; 

IF COLLISION = 0 THEN 

do; 

UI$FLAG = TRUE; 

cur$sym, collision = next$sym; 

CALL BUILD$SYMB0L(VARC (0) ) ; 

SYMBOL (P$LENGTH ) = VARC(0); 

DO I = 1 TO VARC(0); 

SYMBOL ( STARTS NAME + I) * VARC ( I ) J 

end; 

RETURN CURSSYM; 

end; 

ELSE 

do; 

CUR$SYM = collision; 

IF (HOLD := GET$P$LENGTH ) = VARC(0) THEN 

do; 

i = i; 

DO WHILE 

SYMBOL(START$NAME + I) = VARC(I); 
IF (I := I + 1) > HOLD THEN 

RETURN (CUR$SYM := COLLISION); 

end; 

end; 
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end; 

point = collision; 

end; 

end match; 

ALLOCATE: PROC ( BTTES$REQ) ADDRESS ; 

DCL (HOLD ,BYTES $REQ ) ADDRESS; 

HOLD = next$available; 

IF (NEXT$AVAILABLE := NEXT$ AVAILABLE + BYTES$REQ ) 

> MAX$INT$MEM THEN 
CALL FATAL$ERROR( 'MO') 5 
RETURN HOLD; 

END allocate; 

DIGIT: PROC (CHAR ) BYTE; 

DCL CHAR BYTE*, 

RETURN (CHAR <= '9') AND (CHAR >= '0'); 

END digit; 

SET$REDEF: PROC (OLD ,N EW ) J 
DCL (OLD, NEW) ADDRESS J 
REDEF$ONE = OLDJ 
REDEF$TVO = NEW? 

REDEF = TRUE? 

END SET$REDEFJ 

SET$CUR$SYM: PROC; 

CUR$SYM = ID$STACE(ID$STACK$PTR) ; 

END SET$CUR$SYMJ 

STACK$LEVEL: PROC BYTE; 

CALL set$cur$sym; 

RETURN GET$LEVELJ 
END stack$level; 

LOAD$LEVEL : PROCJ 

DCL HOLD ADDRESS; 

LOAD$REDEF$ ADDR : PROCJ 

CUR$SYM = redef$one; 

HOLD = GET$ADDRESSJ 

END load$rsdef$addr; 

IF ID$STACK ( 0 ) <> 0 THEN 

do; 

IF VALUE (SP - 2) = 0 THEN 

do; 

CALL 5ET$CUR$SYM; 

HOLD = GET$S$LENGTH + GET$ADDRESS ; 

end; 

ELSE 
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do; 

IF FILE$SEC$END TEEN 

do; 

IF ID$STACK(ID$STACK$PTR) <> P EDEF$ONE 
TEEN 

do; 

CALL PR I NT $ ERROR ( 'R1 ' ) J 

REDEF$ONE = IT$STACK ( ID$STACK$PTR ) ; 

end; 

end; 

call load$redef$addr; 
end; 

IF (ID$STACK$PTR := ID$STACK$PTR + 1) > S TEEN 

do; 

CALL PRINT$ERRO?.( 'EL'),* 

ID$STACK$PTR = 9J 

end; 

end; 

ELSE HOLD = NEXT$AVAI LABLE J 

CUR$SYM,ID$STACK(ir$STACK$PTR) = VALUE(MPPl); 

IF ( CUR$S YMOOCCURS $PTR ) AND (D$CNT<>0) TEFN 
CALL PROCESS$OCCURS; 

IF (GET$LEVEL = 1) AND (NOT FILE$SEC$END) TEEN 
CALL SET$ADDR2(SAVE$ADDR); 

CALL SET$ADDRESS (HOLD) J 
END load$level; 

REDEF$ OR $ VALUE : PROC,* 

DCL (HOLD ,HOLDl , TEMP) ADDRESS, 

( CHAR ,LVL$NBR ) BYTE; 

IF REDEF THEN 

do; 

IF REDEF$TWO = CUR$SYM THEN 

do; 

hold = get$s$length; 

LVL$NBR = GET$LEVEL; 

cur$sym = redef$one; 

IF HOLD <> (HOLD1 := GFT$S $LENGTE ) THEN 

do; 

IF ( LVL$NBR = 1) 

AND (NOT FILE$SEC $END ) THEN 
do; 

cur$sym = save$addr; 

CALL SET$TYPE(VARIABLE$LENG) ; 
IF HOLD>HOLDl THEN 

CALL SET$S$LENGTH(ECLD); 

ELSE 

CALL SET$S$LENGTH ( SOLDI ) ; 

end; 

IF HOLD > HOLD1 THEN 

do; 
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IF LVL$NBR = 1 THEN 

TEMP = ALLOCATE (HOLD - HOLD1); 
ELSE 

do; 

CALL PR I NT$ERROR( 'R2') J 
CUR$S YM = REDEF$TVO j 
CALL SET $S$LENGTH( HOLD) ? 

end; 

end; 

end; /* END IF HOLD <> */ 

END; /* END IF REDEF$TWO = CUR$SYM */ 

END; /* END IF REFEF */ 

ELSE IF PENDING$LITERAL = 0 TEEN RETURN; 

IF (PENDING$LIT$ID<>ID$STACK$PTR) OR VALUE$FLAG THEN 

return; 

IF PEN DING$ LITERAL <> 0 THEN 

CALL START$IN I TIALIZE(GET$ ADDRESS .HOLD := 
GET$S$LENGTH) ? 

IF PENDING$LITERAL > 2 THEN 

do; 

IF PENDING$LITERAL = 3 THEN CHAR = '0'; 

ELSE IF PEN DING$LITERAL = 4 THEN CHAR = ' 

ELSE IF P EN D I NG$ LITERAL = 5 THEN CHAR = QUOTE? 
CALL FILL$STRlNG(HOLD,CHAR); 

end; 

ELSE IF PENDING$LI TERAL = 2 THEN 

do; 

IF HOLD <= HOLD$LI T ( 0 ) THEN 

CALL STRING$OUT ( .HOLD$LIT(l ) .HOLD ) ? 

ELSE 

do; 

CALL STRING$OUT ( .HOLD$LIT(l ) ,HOLI$LIT( 0 ) ) ; 
CALL FILL$STRI NG (HOLD - HOLD $LIT ( 0 ) , ' '); 

end; 

end; 

ELSE IF PENDING$LITERAL = 1 THEN 

do; 

DCL (H$DEC ,H$ LENGTH ,H ,L ,L$DEC , L$LENGTH , SIGN .TYPE ) 
BYTE, TEMP( 20) BYTE , ZONE LIT '80H'? 

IF ((TYPE := GET$TYPE ) < 16 OR (TYPE > 21 THEN 
CALL PRINT$ERROR( 'NV')J 
LiLENGTH = GET$LENGTH ? 

L$DEC = L$LENGTH - GET$DECIMAL; 

IF TYPE = 20 THEN L$DEC = L$DEC 0 1? 

H^LENGTH = HOLD$LIT(0); 

H$DEC = E$LENGTE + 1? 

SIGN = '+'; 

IF HOLD$LIT ( 1 ) = THEN 
SIGN = 

DO H = 1 TO h$length; 

IF HOLD$LIT(H) = THEN H$DEC = H? 
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end; 

DO L = 0 TO 19; 

TEMP(L) = ' 0 '; 

end; 

L = l$pec - i; 

H = H$DEC J 

DO WHILE ( ( (L := L + 1) < L$LENGTH) AND 
( ( H := H + 1) <= H$LENGTH ) ) » 

TEMP (L ) = HOLD$LIT(H); 

end; 

L = L$DEC ; 

H = H$DEC J 

DO WHILE ( ( ( L := L - 1) < 255) AND 
( ( H := H - 1) > 0) AND 
(HOLD$LIT (H ) <> SIGN)); 

TEMP(L) = HOLD$LIT(H); 

end; 

IF ( (H > 1) OR 

( ( H = 1) AND ( HOLDSLI T ( 1 ) <> SIGN))) THEN 
CALL PRI N T$ERROR ( 'SL')J 
IF SIGN = THFN 

IF TYPE = 17 THEN 

TEMP ( 0 ) = TEMP ( 0 ) OR ZONE; 

ELSE IF TYPE = 18 THEN 

TEMP(L$LENGTH) = TEMP (L$LENGTH) OR ZONE? 
IF TYPE = 19 THEN 

do; 

IF TEMP ( 0 ) <> ' 0 ' THEN 

CALL PRI NT$ERROR ( 'SL' ); 

TEMP ( 0 ) = sign; 

end; 

ELSE IF TYPE = 20 THEN 

temp(l$length - i) = sign; 

IF TYPE = 21 THEN 

do; 

IF SIGN = '+' THEN 

TEMP(L$LENGTH ) = ' 0 '; 

ELSE TEMP(L$LENGTH) = 'l'; 

IF (L$LENGTH MOD 2) THEN L = 0? 

ELSE 

do; 

CALL BYTE$OUT (TEMP (0 ) - 30H)J 
L = i; 

end; 

DO WHILE L < L$LENGTH; 

CALL BYTE$OUT (SHL ( (TEMP(L) - 30H),4) 
OR ( TEMP ( L + 1) - 30E)); 

L = L + 2J 

end; 

DO I = L$LENGTH / 2 + 2 TO L$LENGTHJ 
CALL BYTE$OUT (00H ) : 
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end; 

end; 

ELSE CALL STRING$0UT ( . TEMP , L$LENGTH ) ; 

end; 

IF NOT VALUES FLAG THEN PEND I NG$ LITERAL = 0; 

end redefsorSvalue; 

REDUCESSTACK: PROC; 

DCL HOLDSLENGTH ADDRESS J 
CALL setscurssym; 
call redef$or$value; 

HOLDSLENGTH = GET$S$LENGTH ; 

IF GETSTYPE > OCCURSSTYPE AND GETSTPL$SIZE <> 0 THEN 

do; 

H OLD $LENGTH=EOLD$ LENGTH * GET$TBL$SIZE; 

IF (D$CNT := D$C NT - 1) <> 0 THEN 
OCCURSSPTR = GET$PREV$OCCURS; 

ELSE OCCURSSPTR = 0; 

end; 

id$stack$ptr=id$stacjc$ptr - l; 

CALL setscurssym; 

CALL SETS S$ LENGTH ( GET $S $ LENGTH + HOLDSLENGTH); 

CALL ORSTYPE (GROUP); 

END reducesstack; 
endSofShecord: proc; 

DO WHILE IDSSTACKSPTR <> 0J 
CALL setscurssym; 
call redefsorSvalue; 
idsstack(idsstacksptr) = 0 ; 
idsstacksptr = idsstacksptr - i; 

end; 

call setscurssym; 

CALL REDEFSORSVALUE; 

idSstack ( 0 ) = 0 ; 

TEMPSHOLD = ALLOCATE ( GET $S$LENGTH ) J 

END endsofsrecord; 

convertsinteger: proc; 

DCL integer address; 

INTEGER = 0; 

DO I = 1 TO VARC(0); 

IF NOT DIGIT ( VARC ( I ) ) THEN CALL PRINTSERROR ( 'NN ' ) ; 
INTEGER = SHL ( INTEGER, 3 ) + SHL( INTEGER ,1 ) + 

( VARC ( I ) - ' 0 '); 

end; 

VALUE(SP) = integer; 
end convertsinteger; 

ORSVALUE: PROC (PTR , ATTRIB ) ; 

DCL PTR BYTE, ATTRIB ADDRESS; 
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VALUE (PTR ) = VALUE (PTR) OR ATTRIB * 

END or$value; 

BUILD$FCB: PROCi 

DCL TEMP ADDRESS; 

DCL BUFFER ( 12 ) BYTE, ( CHAR, I , J ) BYTE; 

CALL FILL( .BUFFER, ' ',12); 

IF V ARC (2 ) = THEN 

do; 

BUFFER ( 0 ) = VARC(l) AND 0FHJ 

i = 2; 

end; 

ELSE 

do; 

BUFFER (0 ) = 0; 

i = 0; 

end; 
j = i; 

DO WHILE (J < 12) AND (I< VARC(0)); 

IF (CHAR := VARC(I := I + l)) = THEN J = 9; 

ELSE do; 

BUFFER (J ) = CHARJ 

j = j + i; 

end; 

end; 

CALL SET$ADDR2 (TEMP := ALLOCATE ( 165 )) J 
CALL START$ INITIAL IZE( TEMP , 37 ) ; 

CALL STRING$CUT( .BUFFER, 12); 

CALL FILL$STRING(25,0) J 
CALL OR$ VALUE ( SP - 1,1); 

END build$fcb; 

SET$SIGN : PROC(NUMB); 

DCL NUMB BYTE; 

IF GET$TYPE = 17 TEEN CALL SET$TYPE( VALUE ( SP) + NUMB); 
ELSE CALL PR INT$ERROR ( 'SG ' ) ; 

IF VALUE (SP) <> 0 THEN 

CALL SET$S $LENGTH ( GETS S $ LENGTH + l); 

END set$sign; 

NUM$TRUN C : PROC; 

DCL ( I , J , TRUN C$TYPE, TRUN C$ZERO ,SIGN$FLAG, DECS FLAG ) BYTE? 
TRUNC$ZERO = TRUE J 
SIGN$FLAG ,DEC$FLAG = FALSE; 

HOLD$LIT ( 0 ) , I = 0; 

J = i; 

IF ( ( TRUN C$TYPE := GET$TYPE ) >= 16) 

AND ( TRUN C$TYPE <= 21) THEN 
DO WHILE J <= VARC(0); 

IF (VARC(J) <> '+') AND (VARC(J) <> '-') THEN 

do; 
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IF (VARC(J) = ' 0 ') AND TRUNCiZERO THEN J = j; 
ELSE IF ((VARC(J) >= ' 0 ' ) AND (VARC(J) <= ' 9 ')) 
OR (VARC(J) = TEEN 

do; 

IF DEC$FLAG AND (VARC(J) = THEN 

CALL PRINT$ERROR('MD' ); 

ELSE do; 

EOLD$LIT(HOLD$LIT(0 ) := EOLD$LIT(0) + 1) = 

varc(j); 

IF VARC(J) <> ' 0 ' THEN TRUNCSZFRO = FALSE J 
IF VARC(J) = TEEN DEC$FLAG = TRUE: 
i = i + i; 

end; 

E N D J 

ELSE IF ((VARC(J) < ' 0 ') OR (VARC(J) > '9')) AND 
(VARC(J) <> THEN CALL PRINT$ERROR( 'NN ' ) ; 

end; 

ELSE IF S IGN $FLAG TEEN CALL PRINT$ERROR( 'MS ' ) J 
ELSE IF (VARC(J) = '+') OR (VARC(J) = THEN 

do; 

IF TRUNCmPE = 16 THEN 

CALL PRI NT^ERROR ( 'SG' ) J 

ELSE 

do; 

HOLD $LlT(HOLDi LIT (2 ) : = 

HOLD$LlT ( 0 ) + 1)=VARC(J); 

SIGN $FLAG = TRUE? 

i = i + i; 

end; 

end; 

j = j + i; 

end;/’!' do while loop */ 

HOLD$LIT( 0 ) = i; 

IF ( (HOLD$LIT(0) = 1) AND ( (HOLD $ LI T ( 1 ) = '+') OR 
( EOLD$LI T ( 1 ) = '-'))) OR (EOLD$LIT(0) = ' 0 ') TEEN 
EOLD$LIT(0 ),EOLD$LIT(l) = 0; 

END NUM^TRUNC J 



PI C$AN ALIZER : PROCJ 



DCL /* WORK AREAS 


BUFFER (133) 


BYTE, 


CHAR 


BITE, 


COUNT 


ADDRESS , 


DEC $ COUNT 


BYTE, 


DEC$FLAG 


BYTE, 


DIGITS 


BYTE, 


FLAG 


BYTE, 


FLAGS (3) 


BYTE, 


FLOAT$PS IT 


BYTE, 


FLOAT$VALUE 


BYTE, 


I 


BYTE, 



AND VARIABLES */ 
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J 




ADDRESS, 




K 




BYTE, 




REPITITIONS 


ADDRESS , 




SAVE 




BYTE, 




TEMP 




ADDRESS , 




TYPE 




EYTE , 




/* * * MASKS 


3 ? 3 ? ^ / 




ALPHA 


LIT 


'i;. 




A$SDIT 


LIT 






A$N 


LIT 


'4', 




EDIT 


LIT 


' s ',’ 




NUM 


LIT 


'16 , 




NUM$ED IT 


LIT 


'32', 




DEC 


LIT 


'64', 




SIGNED 


LIT 


'128', 




A$E$MASK 




LIT 


'11111100B 


A$N$MASK 




LIT 


' 1 1 101010B 


A$N$E$MASK 


LIT 


'11100000B 


ALPHA$MASK 


LIT 


'11111110B 


NUM$MASX 




LIT 


'10101111B 


NUM$ED$MASK 


LIT 


' 10000101B 


S$NUM$MASK 


LIT 


'00101111B 


/* TYPES 


*/ 






ATYPE 


LIT 


'8', 




AETYPE 


LIT 


'72', 




ANTYPE 


LIT 


'9', 




ANETYPE 


LIT 


'73', 




NTYPE 


LIT 


'16', 




NETYPE 


LIT 


'80', 




SNTYPE 


LIT 


'l?'; 





I NC$ COUNT : PROC(SWITCH ) ] 

DCL SWITCH BITE? 

FLAG = FLAG OR SWITCH; 

IF (COUNT := COUNT + 1) < 133 THEN 
BUFFER (COUNT ) = CHAR? 

END inc$count; 

CHECK: PROC (MASK) BYTE? 

DCL MASK BYTE? 

RETURN NOT ((FLAG AND MASK) <> 0 ) ; 

END check; 

PIC ^ALLOCATE : PROC(AMT) ADDRESS; 

DCL AMT ADDRESS; 

IF ( MAX$ INT$MEM := MAX $ I NT $ MEM - AMT) 

< N EXT $ AVAILABLE THEN CALL FATAL$EP.ROR ('MO') 
RETURN MAX$INT$MEMJ 
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END pic$allocate; 

SIGN : PROC(CHAR) BYTE; 

DCL CHAR BYTE; 

RETURN (CHAR = '+') OR (CHAP = ' ) ; 

END sign; 

FLOAT$CHECK : PROC(I); 

DCL I byte; 

IF FLOAT$VALUE = 0 AND FLAGS (I) THEN 
FLOAT$VALUE = CHAR; 

IF CHAR <> FLOAT$VALUS AND FLAGS ( I ) THEN 
CALL PRINT$ERR0R('P1') J 
IF FLAGS (I) TEEN 

do; 

FLOAT$PSIT = COUNT + 1J 
DIGITS = DIGITS + l; 

end; 

ELSE 

FLAGS ( I ) = TRUE; 

CALL INC$COUNT(NUM$EDIT) J 

END float$check; 

/* PROCEDURE EXECUTION STARTS HERE */ 

CUR$SYM = hold$sym; 

IF ( GET$LEVEL = VALUE$LEVEL ) THEN VALUE$FLAG = FALSE; 
DEC $FLAG , FLAGS (0 ) , FLAGS ( 1 ) = FALSE; 

FLAGS (2) = TRUE? 

COUNT , DEC iCOUNT, DIG ITS ,FLAG , FLOAT $ VALUE , TYPE = 0J 
/* CHECK FOR EXCESSIVE LENGTH */ 

IF VARC (0 ) > 30 THEN 

do; 

CALL PRINT$ERROR( 'PC'); 
return; 

end; 

/* SET FLAG BITS AND COUNT LENGTH */ 
i = i; 

DO WHILE I <= VARC(0); 

IF (CHAR := VARC ( I ) ) = 'A' THEN 
CALL INC$COUNT( ALPHA) J 

ELSE IF CHAR = 'B' THEN CALL INC £ COUNT ( A $EDIT ) ; 
ELSE IF CHAR = '9' THEN 

do; 

DIGITS = DIGITS + 1 J 
CALL INC$COUNT(NU^) J 

END; 

ELSE IF CHAR = 'X ' THEN CALL INC $COUN T ( A$N ) ; 
ELSE IF (CHAR = 's') AND (COUNT=0) TEEN 
FLAG = FLAG OR SIGNED? 

ELSE IF (CHAR = 'V') AND (DEC$COUN T=0 ) THEN 
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do; 

FLAG = FLAG OR DEC? 

DEC $COUNT = COUNT? 

DEC$FLAG = TRUE; 

end; 

ELSE I F ( C HA R = '/') OR (CHAR='0') TEEN 
CALL INC$COUNT(EEIT); 

ELSE IF CHAR = THEN CALL FLOAT$CHFCK ( 0) J 

ELSE IF SIGN ( CHAR ) THEN CALL FLOAT|CHECK ( 1 ) ,* 

ELSE IF (CHAR = '* ' ) OR (CHAR = 'Z ) TEEN 
CALL FL0AT$CHECK(2); 

ELSE IF CHAR = THEN CALL INC$COUNT(NUM$EDIT ) J 
ELSE IF (CHAR = AND (DEC$COUNT=0 ) TEEN 

do; 

CALL I NC $COUNT ( NUMiEDIT ) ; 

DECSCOUNT = COUNT; 

DEC$FLAG = TRUE; 

end; 

ELSE IF ((CEAR = 'C' AND VARC(I + 1)='R') OR 
(CHAR = 'D' AND VARC(I + l)='3')) AND 
I = VARC(0) - 1 AND NOT FLAGS (l) THEN 

do; 

CALL INC$COUNT(NUM$EDIT) J 
CHAR = VARC ( I : = I +1); 

CALL INC$COUNT(NUM$EDIT) ; 

IF NOT DEC$FLAG THEN 

do; 

DEC iCOUNT = VAR C (0 ) - l; 
DEC$FLAG = TRUE; 

end; 

EN D » 

ELSE IF (CHAR = '(') AND (COUNTO0) THEN 

do; 

SAVE = VARC (I - 1); 

REP ITITIONS = 0,* 

DO WHILE (CHAR := VARC ( I := I + 1)) <> ')'; 
IF CHAR < '0' OR CHAR > '9' TEEN 
CALL PRI NT $ ERROR ( 'P2 ' ) ; 

REPI TITIONS = SHL(REPITITI0NS f 3 ) + 

SHL( REP IT IT IONS , 1 ) + (CHAR - '0'); 

end; 

char = save; 

IF REPITITIONS <> 0 THEN 

do; 

DO J = 1 TO REPITITIONS - 1 J 
CALL INC$COUNT(0) ; 
end; 

IF SIGN( SAVE ) OR SAVE = 

OR SAVE = 'Z' OR SAVE = '9' 

OR SAVE = THEN 
DIGITS = DIGITS + REPITITIONS - i; 



210 



end; 

ELS E 

COUNT = COUNT - 1J 

end; 
else do; 

CALL PRINT$ERR0R('P3' )J 

return; 

end; 
i = i + i; 

END; /* END OP DO WHILE I <= VARC */ 

IF NOT DEC$FLAG AND S IGN ( VARC ( I - l)) THEN 

do; 

DEC$COUNT = VARC(0); 

DEC $FLAG = TRUE? 

end; 

/* AT THIS POINT THE TYPE CAN BE DETERMINED */ 

IF CHECK(NUM$MASK) THEN TYPE = N TYPE; 

ELSE IF CEECK(SNUM$MASK ) THEN TYPE = SNTYPEJ 

ELSE IF CHECK (ALPHA$M ASK ) TEEN TYPE = ATYPE? 

ELSE IF CEECK(A$E$MASK) THEN TYPE = AETYPEJ 

ELSE IF CHECK (A iN iMASK ) THEN TYPE = ANTYPEJ 

ELSE IF CHECK (A$N$S$ MASK) AND (((FLAG AND 06H) O 0) 

OR ((FLAG AND 09E) <> 0) OR ((FLAG AND 12H) <> 0)) 

THEN TYPE = ANETYPE 5 
ELSE IF C HECK (NUM$ED$ MASK) THEN 

do; 

TYPE = netype; 

IF FLOAT$VALUE <> 0 THEN 

do; 

i = i; 

DO WHILE VARC ( I ) <> FLOAT$V>LUE; 
i = i + i; 

end; 

DO I = I + 1 TO FLOAT$PSIT; 

IF VARC (I) <> FLOAT $VALUE AND 
VARC ( I ) <> ' 3 ' AND 
VARC ( I ) <> '/' AND 
VARC ( I ) <> ' 0 ' AND 
VARC (I) <> THEN 

do; 

CALL PR IN T$ ERROR ( 'P4 ' ) ; 

i = float$psit; 

end; 

end; 

end; 

end; 

IF TYPE = 0 THEN CALL PRINT$ERROR( 'P5 ' ) ; 

ELSE do; 

IF (GET$TYPE = 128) TEEN 

CALL SET$TYPE ( 1 28 + TYPE); 

ELSE CALL SET$TYPE( TYPE ) J 
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CALL SET$S LENGTH (COUNT + GET$S ^LENGTH ) » 

IE (TYPE AND 64) <> 0 THEN 

do; 

CALL SET$ADDR2 ( TEMP := 

PI C$ALLOCATE( COUNT ) ) ; 

CALL START$INITIALIZE(TEMP, COUNT) J 
CALL STRINC-$0UT( .BUFFER + 1, COUNT); 

end; 

IF DIGITS > 18 THEN 

CALL PRINT$ERROR ( 'P6 ' ) ; 

IF DEC$FLAG THEN 

CALL SET$DECI MAL( COUNT - DEC$COUNT)J 

end; 

IF (NOT TRUNC $FLAG ) AND ((TYPE = 16) OR (TYPE = 1?)) THEN 

do; 

DO K = 0 TO HOLD$Ll T( 0 ) ; 

VARC(K) = EOLD$LIT(K); 

end; 

CALL NUM$TRUNC; 

TRUNC$FLAG = TRUE; 

end; 

end pic$analizer; 

SET$FILE$ATTRIB : PROC; 

DCL TEMP ADDRESS, TYPE BYTE J 
IF CUR$S YM <> VALUE ( MPP1 ) TEEN 

do; 

temp = cur$sym; 

CUR$SYM = VALUE ( MPP1 ) ; 

SYMBOL$ADDR(REL$ID) = TEMP; 

end; 

IF NOT (TEMP := VALUE (SP - 1)) THEN 
CALL PRlNT$ERROR( 'NF') 5 
ELSE do; 

IF (TEMP = 1) OR (TEMP=5) THEN TYPE=SECUENTIAL 
ELSE IF TEMP = 15 TEEN TYPE=RANDOM; 

ELSE IF TEMP = 13 THEN TYPE=SEQ ^RELATIVE; 

ELSE do; 

CALL PRINT$ERROR ( 'IA ' ) ; 

TYPE = i; 

end; 

end; 

CALL SET$TYPE (TYPE + URiMASK ) J 
END SET$FILE$ATTRIBJ 

LOAD$LITERAL: PROC ( LI T$ONE ) ? 

DCL (I,LIT$ONE,LIT$TYPE) BYTE; 

LI T$ TYPE = GET$TYPEJ 

IF LIT$TYPE <> 0 THEN VALUE$FLAG = FALSE; 

else do; 

VALUE$FLAG = TRUE? 
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VALUE$LEVEL = GET$LEVEL; 

end; 

IF PENDING$ LITERAL <> 0 THEN CALL PR I NT$EP.ROR ('LE')J 
ELSE IF ( LIT $ONE = 0) OR ( LIT$TYPE = 0) THEN 

do; 

DO I = 0 TO VARC(0); 

HOLD$LIT( I ) = VARC(I); 

end; 

IF (LIT$ONE = 1) AND ( LIT$TYPE = 0) THEN 
TRUNC$FLAG = FALSE; 

end; 

ELSE IF ( LIT $ONE = 1) AND ( ( LIT$TYPE >= 16) AND 
(LIT$TYPE <= 21)) THEN 
CALL NUM.$TRUNC > 

ELSE IF ( LI T$ONE = 1) AND ( LIT$T YPE <> 0) THEN 

do; 

CALL PR I NT $ ERROR ( 'LV ' ) ; 

DO I = 0 TO VARC(0); 

HOLD$LIT ( I ) = VARC(I); 

end; 

PEN DING$LITERAL = 2; 

end; 

end load$literal; 

REDEF$TEST : PROCJ 

DCL SAVE$REDEF BYTE, 

(SAVE$REDEF$ONE,SAVE$RFDEF$TWO) ADDRESS; 
SAVE$REDEF$ONE = REDEF$ONE; 

SAVE$REDEF$TWO = REDEF$TWO,* 

redef$one = cur$sym; 
call set$cur$sym; 

IF (GET$TYPE > OCCURS$TYPE) AND (GET$T3L$SIZE <> 0) THEN 
IF (D$C NT := D$C NT -1)00 THEN 
OCCURS $PTR = GET$PREV$ OCCURS J 
ELSE OCCURS$PTR = 0; 

REDEFiTWO = CUR$SYMJ 
SAVESREDEF = REDEF; 

REDEF = TRUE; 

CALL redef$or$value; 

ID$STACK(ID$STACK$PTR) = 0? 

ID$STACK$PTR = ID$5TACK$PTR - i; 

REDEF$ONE = SAVE$REDEF$ONE > 

REDEF$TWO = SAVE$REDEF$TVO J 
REDEF = SAVE$REDEF; 

END REDEF$TEST5 

CHECK$LVL$FILES : PROC; 

DCL NEW$LEVEL BYTE; 

HOLD$SYM ,CUR$SYM = VALUE ( MP - 1); 

CALL SET$LEVEL(N EW$ LEVEL := VALUE (MP - 2)); 

IF NEW$LEVEL = 1 THEN 
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do; 

IF ID$STACK (0 ) <> 0 THEN 

do; 

DO WHILE STACK$LEVEL > i; 

call reduce$stack; 

END* 

DO WHILE ID$STACK$PTR <> 0J 
CALL set$cur$sym; 

CALL REDEF$OR$ VALUE? 
ID$STACK(ID$STACK$PTR) = 0; 

ID$STACK$PTR = ID$STACK$PTR - 1J 

end; 

cur$stm = hold$sym; 

CALL SET$REDEF(ID$STACK(0) , VALUE (MP - l)); 
VALUE (MP) = l; /* SET REDEFINE FLAG */ 

end; 

end; 

ELSE DO WHILE STACK$LEVEL >= NEW^LEVEL? 

CALL reduce$stack; 
end; 

END CHECK$LVL$FILES ? 



CHECK $LVL$ WORK : PROC? 
DCL NEW$LEVEL 
SAVE$SYK$LVL 
STACK$REDUCED 
SAVE$REDEF 
REDEF$FLAG 
SAVE$SYM 



BYTE, 

BYTE, 

BYTE, 

BYTE 

BYTE,’ /*NXT LVL IS A REDEFINES*/ 

address; 



SET $ VALUER CLAUSE : PROCJ 
SAVE$REDEF = REDEF; 

REDEF = FALSE? 

call set$cur$sym; 
call redef$or$value; 

REDEF = SAVE$REDEFJ 

cur$sym = hold$sym; 
end set$value$clause; 

TRUNC$FLAG = TRUE; 

stack$reduced = false; 

HOLD$S YM, CUR$SYM = VALUE(MP - 1); 

CALL SET$ LEVEL ( NEW $LEVEL := VALUE(MP - 2)),* 
REDEF$FLAG = VALUE(MP)? /*SET IN PROD #64*/ 
IF NEW$LEVEL = 1 OR N EW$LEVEL = 77 THEN 

do; 

IF STACK$LEVEL = 77 THEN 

CALL end$of$record; 

ELSE 

do; 

DO WHILE STACK$LEVEL > 1 
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AND ID$STACK( ID$STACK$PTR) <> 0; 

SAVE$SYM ,CUR$SYM = ID$STACK ( ID$STACK$PTR - 1); 
SA VE$SYM$LVL = GET$ LEVFL; 

IF SAVE$SYM$LVL = STACK$LEVEL THEN 

do; 

cur$sym = save$sym; 
call redef$test; 
end; 

ELSE IF STACK$LEVEL > 1 THEN 

do; 

call reduce$stack; 

IF VALUE$FLAG 

AND ( VALUE$LEVEL = STACK$LEVEL ) THEN 

do; 

VALUE$FLAG = FALSE; 

CALL set$valde$clause; 
end; 

end; 

END;/* DO WHILE LOOP */ 

IF STACK$LEVEL = 1 AND I D$STACE$PTR <> 0 THEN 

do; 

CUR$S YM = ID$STACK(ID$STACK$PTR - 1); 

CALL redef$test; 
end; 

IF REDEF$FLAG = 0 

AND ID$STACK(ID$STACK$PTR ) <> 0 THEN 

do; 

call end$of$record; 

REDEF = FALSE; 

end; 

IF ( REDEF$FLAG = 1) 

AND (ID$STACK(ID$STACK$PTR ) = REDEF$ON E ) 

TEEN CALL SET$VALUE$CLAUSS ; 

end; 

end; 

ELSE IF STACKLEVEL = 77 THEN CALL PRINT$ER?.OR( 'L7 ' ) ; 

ELSE IF STACK$LFVEL >= N EW$LEVEL THEN 

do; 

IF (STACK$LEVEL = NEW$ LEVEL) AND (REDEF$FLAG = 1) AND 
(ID$STACK(ID$STACS$PTP.) = REDEF$ON E ) THEN 

CALL set$value$clause; 

DO WHILE NOT STACK$REDUCED ; 

SAVE$SYM , CUR$SYM = ID$STACK( ID$STACK$PTR - 1); 
SAVE$SYM$LVL = GET$LEVEL; 

IF SAVE$SYM$LVL = STACKS LEVEL THEN 

do; 

cur$sym = save$sym; 
call redef$test; 
end; 

ELSE IF (STACK$LEVEL >= NEV$LEVEL) 

AND (REDEF$FLAG = 0) TEEN 
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do; 

call reduce$stack; 

IF VALUE$FLAG AND ( VALUE$LEVEL = STACE$LEVEL) 
AND ( VALUE$LEVEL = NEV$ LEVEL ) THEN 

do; 

VALUE$FLAG = FALSE J 
CALL SET$VALUE$CLAUSEJ 

end; 

IF STACK$LEVEL<NEW$ LEVEL THEN 

stacksreduced = true; 

end; 

ELSE IF (STACK$LEVEL >= NEW$LEVEL ) 

AND (REDEF$FLAG = 1) THEN 

do; 

IF STACK$LEVEL>NEWiLEVEL THEN 
CALL reduce$stack; 

IF VALUE$FLAG 

AND ( VALUE$LEVEL = STACK$LEVEL ) THEN 

do; 

VALUE$FLAG = FALSE; 

CALL set$value£clause; 
end; 

IF STACK$LEVEL <= NEW$LEVEL THEN 
STACK$REDUCED = TRUE; 

end; 

end; /* DO WHILE LOOP */ 
end; 

cur$sym = hold$sim; 

END CEECK$LVL$WORX ; 

CODE$GEN : PROC (PRODUCTION ) ; 

DCL PRODUCTION BYTE, 

LIT$TYPE BYTE? 

IF PR I NT $ PROD THEN 

do; 

call crlf; 

CALL PRINTCHAR(POUND) ; 

CALL PRINT$NUMBER(PRODUCTION ) ; 

end; 

DO CASE production; 

/* PRODUCTIONS*/ 

/* CASE 0 NOT USED */ 

/* 1 <PROGRAM> <ID - DIV> <E - DIV> <D - DIV> */ 

/* 1 PROCEDURE */ 

do; 

COMPILING = FALSE? 

call display$line; 
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end; 



/* 




2 


<ID - DIV> ::= IDENTIFICATION DIVISION . 


*/ 


/* 






PROGRAM-ID . 


*/ 


/* 




2 


<COMMENT> . <ID-LIST> 


*/ 




• 

9 


/* 


NO ACTION REQUIRED */ 




/* 




3 


<ID-LIST> ::= <AUTE> <INS> <DATE> <SEC> 


*/ 


• 

9 




/* 


NO ACTION REQUIRED */ 




/* 




4 


<AUTH> ::= AUTHOR . <COMMENT> . 


*/ 




• 

9 


/* 


NO ACTION REQUIRED */ 




/* 




5 


\! <EMPTY> 


*/ 




• 

1 


/* 


NO ACTION REQUIRED */ 




/* 




6 


<INS> ::= INSTALLATION . <COMMENT> . 


*/ 




• 

9 


/* 


NO ACTION REQUIRED */ 




/* 




7 


\ ! <EMPTY> 


*/ 




• 

* 


/* 


NO ACTION REQUIRED */ 




/* 




9 


<DATE> ::= DATE - WRITTEN . <C OMMEN T> . 


V 




• 

* 


/* 


NO ACTION REQUIRED */ 




/* 




9 


\! <EMPTY> 


*/ 




• 

1 


/* 


NO ACTION REQUIRED */ 




/* 




10 


<SEC> ::= SECURITY . <COMMENT> . 


*/ 




• 

9 


/* 


NO ACTION REQUIRED */ 




/* 




11 


\ ! <EMPTY> 


*/ 




• 

* 


/* 


NO ACTION REQUIRED */ 




/* 




12 


<COMMENT> ::= <INPUT> 


*/ 




• 

* 


/* 


NO ACTION REQUIRED */ 




/* 




13 


\! <COMMENT> <INPUT> 


*/ 




• 

9 


/* 


NO ACTION REQUIRED */ 




/* 




14 


<E - DIV> ::= ENVIRONMENT DIVISION . 


*/ 


/* 






CONFIGURATION SECTION . 


*/ 


/* 




14 


<SRC - OEJ> <1 - 0> 


*/ 




• 

9 


/* 


NO ACTION REQUIRED */ 




/* 




15 


\ ! <EMPTY> 


*/ 


• 

9 




/* NO ACTION REQUIRED */ 




/* 




16 


<SRC - OB J> ::= SOURCE - COMPUTER . <COMMENT> 


*/ 


/* 






<DEBUG> . 


*/ 


/V 




16 


OBJECT - COMPUTER . <COMMENT> . 


*/ 




• 

9 


/* 


NO ACTION REQUIRED */ 




/* 




17 


<DEBUG> ::= DEBUGGING MODE 


*/ 




DEBUGGING = TRUE; /* SETS A SCANNER TCGC-LE */ 




/* 




19 


\ ! <EMPTY> 


*/ 




• 

9 


/* 


NO ACTION REQUIRED */ 




/* 




19 


<I-0> ::= INPUT-OUTPUT SECTION . FILE-CONTROL 


*/ 


/* 




19 


. <FILE - CONTROL - LIST> <IC> 


*/ 




• 


/* 


NO ACTION REQUIRED */ 




/* 




20 


\! <EMPTY> 


* / 




• 

9 


/* 


NO ACTION REQUIRED */ 




/* 




21 


<FILE-CONTROL-LIST> : := <FILE-CONTROL-ENTRY> 


*/ 




• 

9 


/* 


NO ACTION REQUIRED */ 




/* 




22 


\ ! <FILE-CON TROL-LI ST> 


*/ 


/* 




22 


<FILE-CONTROL-ENTRY> 


*/ 




• 

9 


/* 


NO ACTION REQUIRED */ 
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/# 


23 <FILE-CONTROL-ENTRY> ::= SELECT <IB> 


*/ 


/* 




<ATTR IBUTE-LI ST> . 


*/ 




CALL set$file$attrie; 




/* 


24 


<ATTRI3UTE-LIST> ::= <ONE-ATTRIB> 


*/ 




; /* 


NO ACTION REQUIRED */ 




/* 


25 


\! <ATTRIBUTE-LIST> 


*/ 


/* 




<ON E-ATTR I3> 


*/ 




VALUE ( MP ) = VALUE ( SP ) OR VALUE(MP); 




/* 


26 


<ONE-ATTRIB> : : = ORGAN I ZAT ION <ORG-TY?E> 


*/ 




VALUE ( MP ) = VALUE (SP)J 




/* 


27 


\ ! ACCESS <ACC-TYPE> <RELATIVE> 


*/ 




VALUE (MP) = VALUE (MPP1) OR VALUE (SP); 




/* 


23 


\! ASSIGN <INPUT> 


*/ 




call build$fcb; 




/* 


29 


<ORG-TYPE> ::= SEQUENTIAL 


*/ 




; /* 


NO ACTION REQUIRED - DEFAULT */ 




/* 


30 


\ ! RELATIVE 


*/ 




CALL OR$ VALUE ( SP ,4 ) J 




/* 


31 


\ ! INDEXED 


*/ 




CALL PRI NT$ ERROR ( 'NI ' ) J 




/* 


32 


<ACC-TYPE> ::= SEQUENTIAL 


*/ 




; /* 


NO ACTION REQUIRED - DEFAULT */ 




/* 


33 


\! RANDOM 


*/ 




CALL OR$ VALUE ( SP , 2 ) 5 




/* 


34 


<RELATI VE> ::= RELATIVE <ID> 


*/ 




do; 








CALL 


i 0R$VALUE(MP,3); 






CURS YM = VALUE(SP); 






CALL 


i SET$TYPE(REL$KEY$UR) J 






end; 






/* 


35 


\ ! <EMPTY> 


*/ 




; /* 


NO ACTION REQUIRED - DEFAULT */ 




/* 


36 


<IC> ::= I-O-CONTROL . <SAME-LIST> 


*/ 




; /* 


NO ACTION REQUIRED V 




/* 


37 


\ ! <EMPTY> 






; /* 


NO ACTION REQUIRED */ 




/* 


33 


<SAME - LIST> ::= <S AME - ELEMEN T> 


*/ 




; /* 


NO ACTION REQUIRED */ 




/* 


39 


\! <S AME - LIS T> <S AME - ELEMENTS/ 




; /* 


NO ACTION REQUIRED */ 




/* 


43 


<SAME-ELEMENT> ::= SAME <ID-STRING> . 


*/ 




; /* 


NO ACTION REQUIRED */ 




/* 


41 


<ID-STRING> : := <ID> 


*/ 




; /* 


NO ACTION REQUIRED */ 




/* 


42 


\! <ID-STRING> <ID> 


*/ 




; /* 


NO ACTION PECUIRED */ 




/* 


43 


<D-DIV> ::= DATA DIVISION . <FILE-SFCTI CN> 


*/ 


/* 




<WORK> 


*/ 


/* 


43 


<LINK> 


*/ 




; /* 


NO ACTION REQUIRED */ 




/* 


44 


<FILE-SECTION> ::= FILE SECTION . <FILE-LIST> 


#/ 
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FILE$SEC$END = TRUE; 



/* 




45 


\ ! <EMPTY> 


*/ 




FILE$SEC$SND = TRUE; 




/* 




46 


<FILE-LIST> ::= <FILES> 


*/ 




• 

J 


/* 


NO ACTION REQUIRED */ 




/* 




47 


\t <FILE-LIST> <FILES> 


*/ 




• 

J 


/* 


NO ACTION REQUIRED */ 




/* 




46 


<FILES> ::= FD <ID> <FILE-CONTROL> . 


*/ 


/* 


do; 


48 


<REC0RD-DESCRIPTI0N> 


*/ 



DO WHILE STACK$LEVEL > 15 
CALL reduce$stack; 
end; 

CALL END$OF$RECORr; 

REDEF = FALSE? 

end; 

/# 49 <FILE-CONTROL> ::= <FILE-LIST> */ 

CALL SET$IO$ADDRS; 

/* 50 \! <EMPTY> */ 

CALL SETiIO$ADDRS J 

/* 51 <FILE-LIST> ::= <FILE-ELEMENT> */ 

; /* NO ACTION REQUIRED */ 

/* 52 \ ! <FILE-LIST> <FILE-ELEMFNT> */ 

; /* NO ACTION REQUIRED */ 

/* 53 <FILE-ELEMENT> ::= BLOCS <INTEGFR> RECORDS */ 

; /* NO ACTION REQUIRED - FILES NEVER BLOCKED */ 

/* 54 \ ! RECORD <REC-COUNT> */ 

CALL SET$SLENGTE(VALUE(SP) ) J 

/* 55 \ ! LABEL RECORDS STANDARD */ 

; /* NO ACTION REQUIRED*/ 

/* 56 \ ! LABEL P.ECOPDS OMITTED */ 

J /* NO ACTION REQUIRED*/ 

/# 5? \ ! VALUE OF <ID - STRI NG> */ 

; /* NO ACTION REQUIRED */ 

/* 58 <REC-COUNT> ::= <INTEGER> */ 

; /* NO ACTION REQUIRED - VALUE(SP) CORRECT */ 

/* 59 \ ! <INTEGER> TO <IN TEGER> */ 

do; 

VALUE(MP) = VALUE(SP); /* VARIABLE LENGTH */ 

CALL SET$TYPE ( VARIABLE^LENG ) 5 /* SET TO VARIABLE */ 

end; 

/* 60 <WORX> ::= WORKING-STORAGE SECTION . */ 

/* 60 <RECORD-DESCRIPTION> */ 

do; 

IF STACK$ LEVEL 077 THEN 

do; 

DO WHILE STACK$LEVEL > 1? 

CUR$SYM = ID$STACK(ID$STACK$PTR - 1); 

IF GET$LEVEL = STACK$LEVEL THEN 
CALL redef$test; 

ELSE IF STACK$LEVEL > 1 TEEN 
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CALL reducesstack; 

end; 

IF STACK$LEVEL = 1 AND ID$STACK$PTR <> 0 THEN 

do; 

CUR $SYM = ID$STACK(ID$STACE$PTR - l); 

IF REDEF THEN CALL REDEFSTEST; 

end; 

end; 

CALL end$of$record; 
end; 



/* 




61 


\ ! <EMPTY> 


*/ 




• 

9 


/* 


NO ACTION REQUIRED */ 




/* 




62 


<L I NK> ::= LINKAGE SECTION . 


*/ 


/* 




62 


<RECORD-DFSCRIPTION> 


*/ 




• 

9 


/* 


NO ACTION REQUIRED */ 




/* 




63 


\ ! <EM.PTY> 


*/ 




• 

9 


/* 


NO ACTION REQUIRED */ 




/* 




64 


<RSCORD-DESCRIPTION> ::= <LEVEL~EN TRY> 


*/ 




• 

9 


/* 


NO ACTION REQUIRED */ 




/* 




65 


\! <PECORD-DES CRI PTION > 


*/ 


/* 




65 


<LEVEL-ENTRY> 


*/ 




• 

9 


/* 


NO ACTION REQUIRED*/ 




/* 




66 


<LEVEL-ENTRY> <INTEGER> <DATA-ID> 


*/ 


/* 




66 


<REDEFINES> <EATA-TYPE> . 


*/ 



do; 

call load$level; 

IF (PENDING$LITERAL <> 0) AND (NOT VALUE$FLAG ) THEN 
PENDING$LIT$ID = ID$STACK$PTR ; 

end; 

/* 67 <DATA-ID> ::= <ID> */ 

IF NOT UI$FLAG TEEN 

do; 

IF GET$TYPE = REL$KEY$UR TEEN 
CALL SET$TYPE(REL$KEY) ; 

ELSE 

CALL PR IN T$ ERROR ( 'DD' ) ; 

end; 

/* 68 \ ! FILLER */ 

do; 

CUR$SYM, VALUE(SP) = NEXT$SYM; 

CALL BUILD$SYMBOL(0); 

end; 

/* 69 <REDEFINES> ::= REDEFINES <ID> */ 

do; 

IF UI$FLAG THEN 

CALL PRINT$ERROR( 'UD') ; 

CALL SET$REDEF( VALUE( SP ) ,VALUE(SP - 2)); 

VALUE ( MP ) = l; /* SET REDEFINE FLAG ON */ 

IF NOT FILE$SEC$END THEN 
CALL PRINT$ERR0R('R3')J 
CALL check$lvl$vork; 
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/* 



/* 

/* 

/* 

/* 

/* 

/* 

/* 

/* 

r* 

/* 

/* 

/* 

/* 

/* 



/* 

/* 



/* 



end; 

70 



\! <EMPTY> 



IF NOT FILE$SEC$END THEN 
CALL CHECK$LVL$ FILES; 

ELSE CALL CHECK$LVL$VORKJ 
END? 

71 <DATA-TYPE> ::= <PR0P-LIST> 

; /* NO ACTION REQUIRED */ 

72 \ ! <EMPTY> 

; /* NO ACTION REQUIRED */ 

73 <PROP-LIST> : := <DATA-ELEMENT> 

; /* NO ACTION REQUIRED */ 

74 \! <PROP-LIST> <DATA-ELEMENT> 

,* /* NO ACTION REQUIRED V 

75 <DATA -ELEVEN T> ::= PIC <INPUT> 

CALL pic$analizer; 



76 \! USAGE COMP 

; /* NO ACTION REQUIRED-NOT IMPLEMENTED */ 

77 \! USAGE COMP-3 

CALL SET$TYPE(COMP) ? 

78 \ ! USAGE COMPUTATIONAL 

J /* NO ACTION REQUIRED-NOTIMPLEMENTED */ 



79 \! USAGE DISPLAY 

; /* NO ACTION REQUIRED - DEFAULT */ 

80 \ ! SIGN LEADING <SEPARATE> 

CALL SET$SIGN(17) ; 

81 \ ! SIGN TRAILING <SEPARATE> 

CALL SET$SIGN (18); 

82 \ ! OCCURS <INTEGER> INDEXED 

82 <ID> 

; /* NO ACTION ACTION REQUIRED-NOT IMPLEMENTED */ 

83 \ ! OCCURS < I NTEGER> 

do; 



CALL SET$TBL$SIZE( VALUE ( SP ) ) J 
D$C NT = D$CNT + 1J 
CALL PROCESS$OCCURS; 

OCCURS $PTR = cur$sym; 

IF ( TEMP$TVO := GET$LEVEL )=1 OR TEMP$T¥0=77 THEN 
CALL PRINT$ERROR( 'OL') J 

end; 



84 \! SYNC <DIRECTION> 

5 /* NO ACTION REQUIRED - BYTE MACHINE */ 

85 \! VALUE <LI TERAL> 
IF NOT FILE$SEC$END THEN 

do; 

CALL PRINT$ERROR( 'VE') ? 

PENDING$LITERAL = 0J 

end; 

86 <DIRECTION> ::= LEFT 

5 /* NO ACTION REQUIRED */ 



*/ 



*/ 
* / 
* / 
*/ 
*/ 
*/ 
*/ 
*/ 

*/ 

*/ 

*/ 

* / 
*/ 

*/ 



*/ 



*/ 



'*/ 
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/* 87 \ ! RIGHT */ 

; /* NO ACTION REQUIRED */ 

/* 88 \ ! <EMPTY> */ 

; /# NO ACTION REQUIRED */ 

/* 89 <SEPARATE> : := SEPARATE */ 

VALUE ( SP ) = 2? 

/* 90 \ ! <EMPTY> */ 

J /* NO ACTION REQUIRED */ 

/* 91 <LITERAL> ::= <INPUT> */ 

EO * 

IE ( ( LIT$TYPE := GET$TYPE ) < 16) OR 
( LITSTYPF > 21) THEN 

do; 

CALL PRINT$ERROR( 'NV')J 
CALL LOAD$LITERAL(0) J 
PENDING$LITERAL = 2? 

end; 
else do; 

CALL LOAD$LITERAL(l ); 

PENDING$LITERAL = 1? 

end; 

end; 

/* 92 \! <LIT> V 

do; 

CALL LOAD$LITERAL(0); 

PEND I NG$ LITERAL = 2; 

end; 

/* 93 \ I ZERO */ 

PEND I NG$ LITERAL = 3J 

/* 94 \ ! SPACE */ 

PENDING$LITERAL = 4 J 

/* 95 \l QUOTE */ 

PENDING$LITERAL = 5; 

/* 96 <INTEGER> ::= <INPUT> */ 

CALL convert$integer; 

/* 97 <ID> ::= <INPUT> */ 

do; 

VALUE (S P ) = MATCH; /# STORE SYMBOL TABLE POINTERS */ 
IF FILE$DESC$FLAG THEN 
DO? 

FILE$DESC$FLAG = FALSE? 

IF UI$FLAG THEN 

CALL PRINT$ ERROR ( 'UD ' ) ? 

ELSE 

IF GET$TYPE>UR$MASK THEN 

CALL SET$TYPE (GET $ TYPE - UR$MASX ) ? 

ELS ^ 

" CALL PR I NT TERROR ( 'DD' ) J 

end; 

end; 

end; /* END OF CASE STATEMENT */ 
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END code$gen; 



GETIN1: PROC BITE; 

RETURN INDEX1 (STATE); 

END GETINIJ 

GETIN2: PROC BYTE; 

RETURN I NDEX2 ( STATE ) J 
END GETIN2J 

INCSP: PROC; 

IF (SP := SP + 1 ) >= PSTACXSIZE THEN 
CALL FATAL$ERROR( 'SO') J 
VALUE(SP) = 0J /* CLEAR VALUE STACK */ 

END INCSP; 

LOOKAHEAD: PROC; 

IF NOLOOK THEN 

do; 

call scanner; 

IF TOKEN = 2 THEN FILE$DESC$FLAG = TRUE; 

NOLOOK = false; 

IF PRINT$TOKEN THEN 

do; 

call crlf; 

CALL PR I NT $ NUMBER (TOKEN ) ; 

CALL PRI NT$ CHAR ( ' '); 

CALL print$accum; 

end; 

end; 

end lookahead; 

NO$CONFLICT: PROC ( CSTATE ) BYTE; 

DCL (CSTATE, I, J,K) BYTE; 

J = INDFX1 ( CSTATE) J 
K = J + I NDEX2 (CSTATE ) - 1? 

DO I = J TO k; 

IF READl(I) = TOKEN THEN RETURN TRUE? 

end; 

RETURN FALSE? 

END no$conflict; 

RECOVER: PROC BYTE; 

DCL ( TSP , RSTATE) BITE; 

DO forever; 
tsp = sp; 

DO WHILE TSP <> 255; 

IF NO$CONFLICT(RSTATE := STATESTACK(TSP) ) THEN 
Do; /* STATE WILL READ TOKEN */ 

IF SPOTSP THEN SP = TSP - l; 

RETURN RSTATE,* 
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end; 

tsp = tsp - 1 ; 

end; 

CALL SCANNER; /* TRY ANOTHER TOKEN */ 

end; 

end recover; 

END$PASS: PROCJ 

/* THIS PROCEDURE STORES THE INFORMATION REQUIRED BY 
PASS2 IN LOCATIONS ABOVE THE SYMBOL TABLE. THE 
FOLLOWING INFORMATION IS STORED: INPUT BUFFER POINTER. 
OUTPUT FILE CONTROL BLOCK, COMPILER TOGGLES */ 

CALL BYTE$OUT(SCE) ; 

CALL ADDR$OUT (NEXT$AV AILABLE ) J 

CALL MOVE ( .DISPLAY ( 1 ) , .LINE$CTR(0 ) ,5 ) J 

OUTPUT$PTR = OUTPUT$PTR - .OUTPUT$BUFF ? 

LIST$PTR = LIST$PTR - .LIST$BUFF; 

CALL MOVE(. DEBUGGING, MAX$MEMORY - PASS 1 $LEN , PASS 1$LEN ) J 
L: C-0 TO L; /* PATCH TO "JMP 0B000E" */ 

END END$PASSJ 

/’** * * * * PROGRAM EXECUTION STARTS HERE * * * * */ 

CALL MOVE( IN ITIAL$POS , M AX $MEMORY ,RDR$ LENGTH ) 5 
CALL init^scanner; 

CALL INIT$SYMBOL; 

/# # * PARSER * * * * * / 

DO WHILE compiling; 

IF STATE <= MAXRNO THEN /* READ STATE */ 

do; 

CALL INCSP; 

STATESTACK (SP ) = STATE; /* SAVE CURRENT STATE */ 
CALL lookahead; 

I = GETINi; 

J = I + C-ETIN2 - l; 

DO I = I TO JJ 

IF READ1 ( I ) = TOKEN THEN 

do; 

/* COPY THE ACCUMULATOR IF IT IS AN 
INPUT STRING. IF IT IS A RESERVED 
WORD IT DOES NOT NEED TO BE COPIED.*/ 
IF (TOKEN = INPUT$STR) 

OR (TOKEN = LITERAL) THFN 
DO K = 0 TO ACCUM (0) ; 

VARC(K) = ACCUM(K); 

end; 

STATE = READ2(I); 

NOLOOK = true; 
i = j; 
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end; 

ELSE IF I = J THEN 

do; 

CALL PRINT$ERR0R( 'NP' ) ; 

CALL PRINT ( . ( ' ERROR NEAR $')); 
CALL print$accum; 

IF (STATE := RECOVER) = 0 THEN 
COMPILING = FALSE? 

end; 

end; /* do i = i to j; */ 

END; /* END OF READ STATE */ 

ELSE IF STATE > MAXPNO THEN /* APPLY PRODUCTION STATE 

do; 

MP = SP - GETIN2J 
MPP1 = MP + 1 ; 

CALL CODE$GEN (STATE - MAXPNO); 

SP = mp; 

I = GETINi; 

J = STATESTACK(SP) J 

DO WHILE (K := APPLYl(I)) <> 0 AND J <> KJ 
I = I + 1; 

end; 

IF (K := APPLY2 ( I ) ) = 0 TEEN COMPILING = FALSE 
STATE = K; 

end; 

ELSE IF STATE <= MAXLNO THEN /*LOOKAHEAD STATE*/ 

do; 

I = GETINi; 

CALL lookahead; 

DO WHILE (K := LOOKl(I)) <> 0 AND TOKEN <> K; 

I = I + i; 

end; 

STATE = L00K2(I); 

end; 

ELS E 

do; /*push states*/ 
call incsp; 

STATESTACK(SP) = GETIN2 ; 

STATE = GETINi; 

end; 

end; /* DO WHILE compiling */ 

CALL END$PASS; 

end; 



COMPUTER LISTING FOR MODULE PART TWO NPS MICRO-COBOL 



$ TITLE('NPS MICRO-COBOL COMPILER PART 2') PAGEVIDTH( 80) 
PAGEW IDTH (60 ) 

PART2: DO; /* MODULE NAME */ 



/* 


COBOL COMPILER 


- PART 2 


*/ 


/* 


MODULE LOCATED 


AT 103H 


*/ 



/* GLOBAL DECLARATIONS AND LITERALS */ 



DECLARE DCL 


LITERALLY 


'DECLARE', 


LIT 


LITERALLY 


'LITERALLY'; 


DCL FALSE 


LIT 


'0', 


ALPHA$LIT$FLAG 


BYTE 


INITIAL( FALSE), 


CR 


LIT 


'13', 


ERROR 


BYTE 


INITIAL(FALSE) , 


FOREVER 


LIT 


'while true', 


IF$FLAG 


BYTE 


INITIAL (FALSE) , 


LF 


LIT 


'10', 


MAX$ MEMORY 


ADDRESS 


I NITIAL (03103F) , 


PASS1$LEN 


ADDRESS 


INITIAL(353) , 


PASS1 $TOP 


ADDRESS 


INITIAL(0B000H) , 


POUND 


LIT 


'23H', 


PROC 


LIT 


'PROCEDURE', 


QUOTE 


LIT 


'27E ' , 


TRUE 


LIT 


'l'; 



MAXLNO 


LIT 


'179', 


/* 


MAX LOOK COUNT */ 


MAXPNO 


LIT 


'196', 


/* 


MAX PUSH COUNT */ 


MA XRNO 


LIT 


'136', 


/* 


MAX READ COUNT */ 


MAXSNO 


LIT 


'345', 


/* 


MAX STATE COUNT #/ 


PRODNO 


LIT 


'149', 


/* 


NUMBER OF PRODUCTIONS */ 


STARTS 


LIT 


' 1 ', 


/* 


START STATE */ 


ENDC 


LIT 


'22', 


/* 


END */ 


FOFC 


LIT 


'19', 


/* 


EOF */ 


PROCC 


LIT 


'80', 


/* 


PROCEDURE */ 


TERMNO 


LIT 


'81'; 


/* 


TERMINAL COUNT */ 



DCL READl(-) BYTE 

DATA( 0,80 ,14, 15 ,20 ,26,26 ,32,34 ,36 ,38, 44,45,54, 55, 57 ,58, 64 
,65,69,70,75 ,77,63,3,41 ,63,63,3,4,7,41 ,63,78,41,63,42,41 
,42,49,50,63,76,23,48,61 ,47,25 ,41 ,42 ,49 ,50 , 63 , 16 , 1 ,53 ,35 
,63,74,1 ,72,3,43,56,39,2,10,11 ,31,46,66,68,81,14,15,20,26 
,28,32,33 ,34,36,38,44,54,55,57 ,58 ,64 , 65 ,69 ,70 ,75 , 77 , 13 , 13 
,30,13,51 ,5,8,41,52,63,73,78,21 ,6,21 ,11 ,71 ,60,60 ,71 ,60,71 
,1,27,59,59,18,24,18,41,60,63,12,22 ,67, 14, 20,26, 2e, 32, 34 
,38,44,54,55,57,58,64,65,69,70,75,77,29,41,60,63,29,67 ,1 
,1,14,15,20,26,28,32,34,36,38,44,54,55,57,58,64,65,69,70 
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,75,77,4,7,4,6,7,14,15,17,20,26,28,32,33,34,36,38,44 .54 
,55,57,58,64,65,69,70,75,77 ,17,63,79,52 ,19,63 ,37 ,40,41 ,42 
,49,50,63,6,9,3,41 ,42 ,49 , 50 , 63 ,0 ,0 ) J 
DCL L00K1 (*) BYTE 

BATA (0,19 ,63,0,63,0,3,0,53,0,63,79,0,63,0,43,56,0,3,0,39 
,0,5, 8,0, 5, 8, 0*5,8, 0,5, 8, 0,5, 8, 0,41 , 52, 63, 73, 0,21, 0,21,0, 
,71,0,71 ,0,60,71 ,0,60,71,0,71 ,0,71,0,71,0,71,0,71 ,0,2,10 
,11 ,24,31 ,46,66,68,81,0,23,48 ,61 ,0 , 12 ,0 ,12 , 2 , 12, 0 ,53 ,0 ,67 
,0,63,0,63,0 ,27,59,0,4,7,0 ,63,0,17,0,63,0,37.0,40,41 ,42 
,49,50,63,0,19,63,0); 

DCL APPLY1 (*) EYTE 

DATA (0,0 ,113,0,19,0,0,128,0,0 ,134,0 ,71 ,105,110,119,123 
,130,0,0,0,0,133,0,0,127,0,0,0,0,0,71,119,123,0,71,0,0 
,105,110,130,0,0,0,6,0,7,8,10,11,0,9,12,0,15,0,105,110 
,130,0 ,41 ,0,4,21 ,0,25,0,0,0,0,88,90 ,91 ,92,93,94,95,96 ,0,0 
,0,0,0,0,114,0,0,0,0,0,102,0 ,16,17,22,23,28,30,47,48,49 
,50,51 ,52,57,66,0,0,2,16,17,19,22,23,27,28,30,34,37,39,40 
,42,43 ,44,45,47,48,49,50,51 ,52,54,55,57,62,66,115,116,122 
,125,126,128,132,133,0,6,7,8,9,13,11 ,12,14,15,18 ,24,29,46 
,59,60,81 ,103,111 ,0,16,17,22,23,28,30,44,47,48,49,50,51 
,52,57,66,0,0,0,36,0,0,31,53,104,131 , 0, 0,0,0 ) ; 

DCL READ2 (*) ADDRESS 

DATA (0,63, 19, 345, 24, 26, 138, 31 ,33,34,36,39,40,43,44,45 ,46 
,52,53 ,54 ,55,59,60,331,6,329,139,332,6,7,10,329,139,218 
329,139,333,329,334,336,335,139,249,322,320,321,313,301 
339,334,336,335,338,20,206,42,319,325,140,137,56 ,5,317 
,319,37,296,295,297,293,294,292,287 ,288,19,345,24,26,133 
,31 ,32,33,34,36,39,43,44,45,46,52,53,54,55,59,60,18,16,30 
,17,234,9,12,329,41 ,139,57 ,61 ,25 ,286,25,14,298,49,50,298 
,51 ,298,2,250 ,247 , 246 , 23 ,290 , 22 ,329 ,47 , 139 , 1 5 ,303 ,312 , 19 
24,26,138,31,33,36,39,43,44,45,46,52,53,54,55,59,60,28 
,329,48,139,29,312,207,208,19,345 ,24,26,138,31,33 ,34,36 
,39,43 ,44,45,46,52,53,54,55 ,59,60 ,8 ,1 1 , 8 , 276 , 11 , 19 ,345 ,21 
,24,26,138,31,32,33,34,36,39,43,44,45 ,46,52,53,54,55 ,59 
,60,21 ,326,62,41,197,326,35,38,329,334,336,335,139,330,13 
,4,329,334,336,335,139,0,0) ; 

DCL L00K2 (*) ADDRESS 

DATA( 0,204, 204, 3, 27, 180, 326, 327, 58, 181 ,200,200,220,66,162 
,67,67 ,183,68,324,69,184,76,76,265,77,77,268,78,78,269,79 
,79,266,80,80,267,81,81,81,81,165 ,83,260,85,281,87,186 ,68 
,187,90,90,188,91,91,189,92,190,93,191 ,9*, 192 ,95 , 193 ,96 
,194,195,195,195,101,195,195,195,195,195,284.102,102,102 
,223,106,270,107,271,108,272,113,196,114,216,115,230,116 
,231 ,248,248,119,120,120,260,122,215,124,238,125,198,129 
,213,131 ,131 ,131,131,131,131,217,205,205,134) ; 

DCL APPLY2 (*) ADDRESS 

DATA (0,0, 214, 97, 126, 176, 128, 203, 202, 179, 116, 117, 306, 244 
,245,307,306,243,209,174,178 ,164,171 ,170,224,236,235 ,112 
,127,72,240,308,309,306,210,99,98,71,213,213,213,177,103 
,111,121,173,147,149,148 ,150,146,166,167,165,274,273,216 
,216,216,169,175,123,84,153,152,283 ,282,285,70,104,252 
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,253,256,258,259,254,255,257,251,225,110,211,172,151,105 
,302,130,279,82,314,133,132,89,157,154,222,158,156,155 
,159,160,161 ,162,86,239,304,212,318,64,144,144,141,144 
, 144 ,342 , 144 , 1 44 , 344 , 310 , 226 , 142 , 200 , 1 43 , 144 , 277 , 144 , 1 44 
,144,144,144,144,145,278,144,221,144,233,233,227,201,201 
,64,232,232,65,275,275,275,275 ,275,275,275,275,275,242 
, 261 ,241 ,73 , 74 ,263,75 , 262 , 264,340 ,323,323, 323 , 323 , 323 ,323 
,323 ,323,323,323,323,323,323,323 ,323,328 , 135 , 168,337 ,341 
,300,100,228,289,229,163,219,109,136) ; 

DCL INDEX1 (*) ADDRESS 

DATA (0,1 ,203,2,217,23,28,24,24,24,24,24,24,27,28,24,203 
,203,34,203,33,217,203,203,34,217 ,36,203,203,34,203,37,42 
,43,203,46,47,203 , 53 , 203,203 ,217,203,203,203, 203 ,34,203 
,203,203,203,203,203,37,203,203,54,203,55,34,34,56,203,56 
,59,61 ,203,62,61,64,65,73,94,95,97,98,99,99,99,99,99 ,101 
,105,106,107,106,109,110,110,111 ,112,114,110, 110 ,110,110 
,110,116,117,119,120,121,43,122,37,129,126,126,126,127 
,129,147,151 ,55,152,203,203,153,154,155,175,177,203,180 
,202,203,203,205,206,208,129,209,203,203,2,215,217,1.4 ,6 
,8, 10,13,15,18,20,22,25,28,31,34,37,42,44,46,48,53,53,56 
,58,60,62,64,66,76,80,82,84,86 ,88 ,90 ,92 ,94 ,97 , 100 , 102 , 104 
, ,106,108,115,343,199,305,315 ,311 ,237,299,299,299,299,299 
,299,299,299,299,291, 199,1,2,2,4,4,6,6,7,7,7,9,9,10,10,10 
,12,12 ,12,12,12,12,12,12,12,12,12 ,12,12,12,19,19,20,20,21 
,21,22,22,24,24,24,24,25,27,28,29,30,31 ,3 1 ,31 ,31 ,31 ,35 ,35 
, 37, 38, 38 ,38, 38, 38, 3e, 38, 38, 38, 38, 42, 42, 43, 43, 44, 44, 44, 44 
,44,46,46,46,51,51,54,54,56,56,56,60,60,62,62,65,65,65,67 
,67 ,67 ,68,68,69,69,69,69,69,69,70,70,79,79,80 ,80 ,81 ,81 ,82 
,82,82,82,63,63,64,86,67,87 ,88,88,69,89,90,90,90,92,92 
,107,108,145,145,145,164,180,180,181 ,182, 182,182,184 ,184 
,184,185,185,190,190,191,192); 

DCL INDEX2 (*) BYTE 

DATA (0,1, 1,21, 6, 1,5, 3, 3, 3, 3, 3, 3,1 ,5, 3,1, 1,2, 1,1, 6, 1,1, 2, 6 



, 1 . 1,1 
, 1 , 1,1 
, 1 . 1,2 
,18,4, 
,6,3 ,2 
,4,2,2 
,90,91 
, 2 , 1,0 
, 1 , 1,1 
, 2 , 1,1 
, 0 , 0,0 
, 0 , 0,0 



,2,1,5, 
, 1 , 1 , 2 , 
. 1 , 1 , 1 , 
1 , 1 , 1,1 
,2,2,3, 
, 2 , 2 , 2 , 
,92,93, 
, 2 , 1 , 0 , 
, 1 , 2 , 2 , 
, 0 , 2 , 2 , 
, 0 , 0 , 0 , 
, 0 , 0 , 0 , 



1.3.1 

2 . 2.1 
1 , 1,2 
, 1 , 1 , 

2.3.2 

2.2.3 
94,95 
1,4,1 

2.5.3 
0 , 2,0 
0 , 0,0 
0,0,3 



, 1 , 6 , 1,1 
, 1 , 2 , 1,1 
, 2 , 1 , 1,1 
1,20,2,3 
,2, 3, 3, 3 
,3, 2, 2, 2 
,96,101, 
,1,3, 3,1 
,0,1, 0,4 
, 2 , 1,1 ,2 
,0,0, 0,0 
, 0 , 2 , 0,0 



, 1 , 1 , 6 , 
, 2 , 1 , 1 , 
, 1 , 1 , 1 , 
,1 , 22,1 
,3,3,5, 
,2,7,3, 
113,5,1 
,3,1,0, 
,4,4,6, 
, 0 , 2 , 0 , 
, 1 , 0 , 1 , 
, 0 , 0 , 0 , 



1 , 1 , 1 , 
8 , 21,1 
2 , 1 , 1 . 
,1 . 2,1 
2 , 2 , 2 , 
27,58, 
, 0 , 0,1 
1 , 0 , 1 , 
6,4,6, 
2 , 0 , 2 , 
1 , 0 , 0 , 
0 , 0 , 0 , 



1 , 2 , 1 , 1 , 1 , 1 , 
, 2 , 1 , 1 , 2 , 2, 2 
1 , 3 , 4 , 5 , 18,1 
, 2 , 1 , 18 , 6 , 1 , 
2 , 3 , 3 , 2 , 2 , 2 , 
66 , 67 , 69 , 81 , 
, 0 , 1 , 1 , 2 , 2,1 
1 , 2 , 0 , 1 , 1 , 0 , 

4 . 4 . 3 . 0 . 1 . 0 , 

2 . 0 . 0 . 1 . 0 . 0 , 
1 , 2 , 0 , 0 , 0 , 0 , 
0 , 0 , 0 , 1 , 0 ) ; 



1,1 ,5 
,2,2,4 
, 1 , 1,2 
1 , 21,2 
2 , 2,10 
87,68 
, 2 , 0,0 
2 , 0,1 
1 , 0,2 
0 , 0,0 
0 , 0,0 



/* END OF TABLES */ 

TlV r* T t BIT 

/* JOINT DECLARATIONS */ 

/* TEE FOLLOWING ITEMS ARE DECLARED TOGETHER IN THIS 
GROUP IN ORDER TO FACILITATE THEIR BEING PASSED PROM 
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THE FIRST PART OF THE COMPILER. 



*/ 




DEBUGGING 


BYTE, 


ERROR$CTR (5 ) 


BYTE, 


LI NE$CTR ( 5 ) 


3YTE , 


LI ST iBUFF (12 8) 


EYTE, 


LIST$FCB (33 ) 


BYTE, 


LIST$INPUT 


BYTE, 


LISTiPTR 


ADDRESS , 


MAX$ IN T$ MEM 


ADDRESS, 


NEXT$AVAILA3LE 


ADDRESS , 


NEXT^S YM 


ADDRESS , 


N 0$C0DE 


BYTE, 


OUTPUT$BUFF ( 128 ) 


BYTE, 


0UTPUT$FCB(33) 


BYTE, 


CUTPUT$PTR 


ADDRESS , 


POINTER 


ADDRESS , 


PRI NT$PROD 


BYTE, 


PRI NT$TOKEN 


BYTE, 


SE0$NUM 


BYTE, 


WRITE$LST 


BYTE, 


HASH$TAB$ ADDR 


ADDRESS , 



/* ADDRESS OF THE BOTTOM OF 
THE TABLES FROM PARTI */ 



/* I 0 BUFFERS AND GLOBALS */ 



I N$ ADDR 
I NPUTFCB 
LI STiCHAR 
LIST$END 
OUTPUT$CHAR 
OUTPUT$EN D 



ADDRESS INITIAL (5CH ) , 
BASED INADDR (33) BYTE, 
BASED LIST$PTR BYTE, 
ADDRESS , 

BASED OUTPUT$PTR BYTE, 

address; 



/* GLOBAL PROCEDURES */ 



DECLARE 

CTR EYTE , 

A$CTR address; 

MON1: PROC (F,A) EXTERNAL; 

DCL F BYTE, A ADDRESS; 

END MONi; 

M0N2: PROC (F,A) BYTE EXTERNAL; 

DCL F BYTE, A ADDRESS; 

END MON 2; 

BOOT: PROC EXTERNAL; 

END boot; 

PRINT$CHAR : PROC (CHAR); 
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DCL CHAR 3YTEJ 
CALL M0N1 (2, CHAR); 

END printcear; 

VRITE$OUTPUT: PROC (BUFF.FCB); 

DCL (BUFF ,FCB ) ADDRESS; 

CALL MON1 (26,BUFF) ; /* SET DMA */ 

IF M0N2(21,FCB) <> 0 THEN 

do; 

CALL MON 1(9, . ( 'WR$') ) J 
CALL boot; 

end; 

CALL MON1(26,80H); /PRESET DMA */ 

END write$output; 

WRlTE$TO$DISK : PROC(CEAR); 

DCL CHAR BYTE; 

IF ( LI ST$PTR := LIST$PTR + l) > LIST$END TEEN 

do; 

CALL WRITE$OUTPUT( . LIS T$ BUFF, . LIST$FCB) ? 
LIST$PTR = .LIST$BUFF; 

end; 

LIST$CHAR = CEAR; 

end write$to$disk; 

PRINT: PROC (A); 

DCL (A ,ADDR ) ADDRESS, CEAR BASED ADDR BYTE? 

ADDR = A; 

CALL MON1 (9, A); 

DO WHILE CHAR <> '$'? 

CALL WRITES TO $DISK( CHAR ) ? 

ADDR = ADDR + 1J 

end; 

END print; 

CRLF: PROC; 

CALL M0N1(9,.(CR,LF, '$')); 

END crlf; 

DCRLF: PROC J 

CALL WRITE$TO$DISK(CR) ; 

CALL WRITE$TO$DISK(LF); 

END dcrlf; 

INC$CTR: PROC (BASE); 

DCL BASE ADDRESS, CTR BYTE, B$BYTE BASED 3ASE (l) BYTE, 
TEN LIT '3AH'; 

CTR = 4J 

DO WHILE (B$BYTE( CTR) := B$BYTE( CTR ) + 1) = TEN; 

Bi BYTE (CTR ) = '0'; 

IF CTR > 0 TEEN 
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TEEN 



IF B$EY?E( CTR := CTR - 1) = ' ' 
B$BYTE(CTR) = '3'; 

end; 

end inc$ctr; 

PRI NT$ERROR : PROC (CODE); 

DCL CODE ADDRESS ,C0DE1(6) ADDRESS, I BYTE? 

IF CODE = FALSE THEN 

do; 

DO I = 0 TO 5J 

CODEl(I) = 0; 

end; 

I = 0; 

end; 

ELSE IF CODE = TRUE THEN 

do; 

1 = 0; 

DO WHILE ( (I <> 6) AND (CODEl(I) <> 0)); 
CALL PRINTCHAR(HIC-H(CODEl(I )) ) ; 

CALL PRI N TCHAR ( LOW (CODEl(I))); 

CALL WRITE$T0$DISK(HIGH(C0DE1(I )) ),* 
CALL WRITE$TO$DISK(LOW (CCDEl(I))); 
CALL crlf; 
call dcrlf; 

CODEl(I) = 05 
I=I+i; 

end; 

1 = 0; 

ERROR = FALSE; 

end; 

ELSE IF (CODE = 'NP') OR (CODE = 'NV') 

OR (CODE = 'SL') THEN 

do; 

ERROR = TRUE; 

CALL PRINTCEAR(HIGH( CODE ) ) ; 

CALL PRINTCHAR(L0W (CODE)); 

CALL WRITE$TO$DISK(HIGH(CODE) ); 

CALL WRITE$TO$DISE ( LOW (CODE)); 

CALL INC$CTR ( . ERROR iCTR ( 0 ) ) 5 
IF CODE <> 'NP' THEN 

do; 

CALL crlf; 

CALL dcrlf; 

end; 

end; 
else do; 

ERROR = TRUE; 

IF I <> 6 THEN 

do; 

CODEl(I) = code; 

1 = 1 + 1; 
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end; 

CALL INC$CTR( . ERAOR$ CTR ( 0 ) ) ; 

end; 

end print$error; 

FATAL$ERROR : PROC ( REASON ) J 
DCL REASON ADDRESS; 

CALL PR I NT$ ERROR (REASON ) J 
CALL PRINTS ERROR ( TRUE ) ; 

CALL boot; 
end fatal$error; 

CLOSE: PROC(FCB); 

DCL FCB ADDRESS; 

IF M0N2(16,FCB ) = 255 THEN CALL FATAL$ERROR ( 'CL ' ) J 
END close; 

MORE$INPUT: PROC BYTE? 

DCL DCNT BYTE? 

IF (DCNT := MON2 (20 , . INPUT$FCB) ) > 1 THEN 
CALL FATAL$ERROR( 'BR ' ) ; 

RETURN NOT (DCNT ) ; 

END moresinput; 

MOVE: PROC (SOURCE, DESTINATION, COUNT); 

DCL (COUNT, SOURCE, DESTINATION ) ADDRESS, 

(S$BYTE BASED SOURCE, D$BYTE BASED DESTINATION) BYTE; 
DO WHILE (COUNT := COUNT -1)0 0FFFFH; 

DSBYTE = SSBYTEJ 
SOURCE = SOURCE +i; 

DESTINATION = DESTINATION + i; 

end; 
end move; 

FILL: PROC(ADDR, CHAR, COUNT); 

DCL (ADDR, COUNT) ADDRESS, 

(CHAR ,DES T BASED ADDR) BYTE,* 

DO WHILE (COUNT := COUNT - 1) <> 0FFFFE; 

dest=char; 

ADDR=ADDR + l; 

end; 

end fill; 



/# # * # 




SCANNER LITS 


DECLARE 


INPUT$STR 


LIT 


'63' , 


INVALID 


LIT 


'0', 


LITERAL 


LIT 


'42' , 


LPARIN 


LIT 


'3', 


PERIOD 


LIT 


'1\ 
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RPARIN LIT ' 6 '; 

/* * * * * SCANNER TABLES * 5(5 * * 



V 



DCL TOKEN$TABLE (*) BYTE DATA 

/* CONTAINS THE TOKEN NUMBER ONE LESS TEAN THE FIRST 
RESERVED WORD FOR EACH LENGTH OF WORD */ 
(0,0,12,18,25,42,54,63,73,77,80) , 

TABLE (*) BYTE DATA( 'BY ' , 'GO ' , ' IF ' , 'N 0 ' , 'OB ' , 'TO ' , 'EOF ' , 'ADD ' 
, 'AND', 'END 'I-O', 'NOT', 'RUN ', 'CALL', 'ELSE', 'EXIT' 

, 'FROM', 'INTO', 'LESS', 'MOVE' , 'NEXT', 'OPEN ', 'PAGE ', 'READ ' 

, 'SIZE', 'STOP', 'THRU', 'WITH ', 'ZERO ' , 'AFTER ', 'CLOSE ' 

, 'ENTER', 'EQUAL', 'ERROR', 'INPUT ' , 'QUOTF', 'TIMES' , 'SPACE' 

, 'UNTIL', 'USING', 'WRITE', 'ACCEPT', 'BEFORE ', 'DELETE' 

, 'DIVIDE' , 'END-17', 'GIVING' , 'OUTPUT ', 'COMPUTE ', 'DISPLAY' 

, 'GREATER ', 'INVALID', 'NUMERIC' , 'PERFORM', 'REWRITE' 

, 'ROUNDED', 'SECTION ', 'VARYING', 'DIVISION ', 'MULTIPLY' 

, 'SENTENCE', 'SUBTRACT', 'ADVANCING', 'DEPENDING' 

, 'PROCEDURE', 'ALPHABETIC'), 

OFFSET (11) ADDRESS INITIAL 



/* NUMBER 


OF BYTES TO 


INDEX INTO THE 


LENGTE 


*/ 




(0,0,0,12 ,33 ,97,157,199,269,301 ,328) , 


WORD$COUNT (*) 


BYTE DATA 




/* NUMBER OF WORDS OF 


EACH SIZE */ 


(0,0,6,7,16 


,12,7,10.4, 


3,1), 


ACCUM ( 82 ) 


BYTE, 




ADD$END(*) 


BYTE 


DATA( ' EO; 


BUFFER$END 


ADDRESS 


INI TI AL( 100H ) , 


CHAR 


BYTE 


INITIAL ( ' '), 


DISPLAY ( 88) 


BYTE 


INITIALS) , 


EOFFILLER 


LIT 


'1AH ' , 


FIRSTSLINE 


BYTE 


INITIAL(TRUE) , 


FORMFEED 


LIT 


'0CH ' , 


EOLD 


BYTE, 




INBUFF 


LIT 


'80H ' , 


LOOKED 


BYTE 


INITIAL(0) , 


MAX$ID$LEN 


LIT 


'15', 


MAX$LEN 


LIT 


'10' , 


NEXT 


BASED 


POINTER BYTE 


TAB 


LIT 


'09' , 


TOKEN 


byte; 


/^RETURNED FROi 



'). 



/* PROCS USED BY THE SCANNER */ 

NEXT$CHAR: PROC BYTE; 

IF LOOKED THEN 

do; 
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LOOKED = FALSE; 

RETURN (CHAR := HOLD)? 

end; 

IF (POINTER := POINTER + 1 ) >= BUFFER$END THEN 

do; 

IF NOT MORE$I NPUT THEN 

do; 

BUFFER$FND = .MEMORY; 

POINTER = .AED$END; 

end; 

ELSE POINTER = IN3UFF? 

end; 

IF NEXT = EOFFILLER TEEN 

do; 

BUFFER$END = .MEMORY; 

POINTER = .AED$END; 

end; 

RETURN (CHAR := NEXT); 

END nextscear; 

GET$CHAR: PROC5 

CHAR = NEXT $ CHAR? 

END get$char; 

DISPLAY$LI NE : PROC? 

DCL I byte; 

DO I = 1 TO DISPLAY (0 ) ? 

IF LIST $ INPUT OR ERROR THEN 

CALL PRI NT $ CHAR (DI SPLAY ( I ) ) ; 

IF WR ITE$LST OR ERROR THEN 

CALL WRITE$T0$DISK (DISPLAY ( I ) ) ? 

END? 

IF FIRST$LINE TEEN 
DO? 

CALL MOVE(.LINE$CTR, .DISPLAY (1),5) ? 
FIRST$LINE = FALSE? 

end; 

ELSE CALL INC$CTR( .DISPLAY (0) ) ? 

DI SPLAY ( 0 ) = 5? 

END display$line; 

LOADiDI S PLAY : PROCJ 

IF DISPLAYS) < 87 TEEN 

DISPLAY ( DISPLAY (0 ) := DISPLAY(0) + l) = GEAR? 
CALL GET$CHARJ 

END load$display; 

PUT: PROC? 

IF ACCUM ( 0 ) < 81 THEN 

ACCUM( ACCUM ( 0 ) := ACCUM(0) + 1) = CHAR; 

CALL load$display; 
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END put; 



EAT$LINE: PROCJ 

DO WHILE CHAR <> CR; 

CALL load$display; 

end; 

end eat$line; 

GET$N 0$BLANK : PROC,* 

DCL I byte; 
do forever; 

IF CHAR = ' ' OR CHAR = TAB THEN CALL LOAD$DI SPLAY ; 
ELSE IF CHAR=CR THEN 

do; 

call load$display; 

CALL LOAD$DI SPLAY? 

call display$lins; 

CALL PRINT$ERROR( TRUE ) J 
DO WHILE CHAR = CR J 

CALL load$display; 
call load$display; 
call display$line; 

end; 

IF SEQ.$NUM THEN 
DO I = 1 TO 61 

CALL load$display; 

end; 

IF CHAR = THEN CALL EAT^LINEJ 
ELSE IF CHAR = '/' THEN 

do; 

IF LISTiINPUT THEN 

CALL PRIN T$ CHAR (FORM$FEEB ) J 
IF WRITE$LST THEN 

CALL WR I TE$TO$DISK (FORMFEED ) ; 
CALL eat$line; 

end; 

ELSE IF CHAR = THEN 

IF NOT DEBUGGING TEEN CALL EAT$LINE; 
ELSE CALL LOAD$DISPLAY 5 

end; 

ELSE return; 

end; /* END OF DO FOREVER */ 

END get$no$blank; 

SPACE: PROC EYTEJ 

RETURN (CHAR = ' ' ) OR (CEAR = CR ) OR (CHAR = TAB); 

END space; 

LEFT$PARIN: PROC BYTE? 

RETURN CEAR = '('; 

END leftsparin; 
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RIGET$PARI N : PROC BITE » 

RETURN CHAR = ')'; 

END right$parin; 

DELIMITER: PROC BITE; 

IF CHAR <> THEN RETURN FALSE; 

HOLD = next$char; 

LOOKED = TRUE; 

IF SPACE TEEN 

do; 

CHAR = 

RETURN TRUE; 

end; 
char = 

RETURN FALSE; 

end delimiter; 

END$OF$TOKEN: PROC BITE? 

RETURN SPACE OR DELIMITER OR LEFT$PAR IN OR RIGET$PARIN 
END end$of$token; 

GET$LITERAL: PROC BITEJ 
CALL LOAD$D ISPLAI ; 

DO forever; 

IF CHAR = CUOTE THEN 

do; 

CALL LOAD$DI SPLAI ? 

RETURN LITERAL; 

end; 
call put; 

end; 

end get$literal; 

LOOK$UP : PROC BITEJ 

DCL POINT ADDRESS, 

HERE BASED POINT (1) BITE, I EITSJ 

MATCH: PROC BITEJ 
DCL J bite; 

DO J = 1 TO ACCUM(0); 

IF HERE( J - 1) <> ACCUM(J) THEN RETURN FALSE J 

end; 

RETURN TRUE? 

end match; 

POINT = OFFSET(ACCUM(0) ) + .TABLE; 

DO I = 1 TO WORD$COUNT( ACCUM(0) ) ; 

IF MATCH THEN RETURN I? 

POINT = POINT + ACCUM(3); 

end; 
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RETURN FALSE; 

END lookup; 

RESERVED$VORD: PROC BYTE* 

DCL (NUMB , VALUE) EYTEJ 
IF ACCUM ( 0 ) <= MAX$LEN THEN 

do; 

IF (NUME := TOKEN $TABLE( ACCUM (0 ) ) ) O 0 THEN 
IF (VALUE := LOOK$UP ) <> 0 TEEN 
NUMB = NUMB + VALUE; 

ELSE NUMB = 05 

end; 

ELSE NUMB = 0J 
RETURN NUMB; 

end reserved$vord; 

GET$TOKEN : PROC BYTE? 

ACCUM ( 0 ) = 0J 

CALL get$no$blank; 

IF CHAR = QUOTE THEN RETURN GET$LITERAL > 

IF DELIMITER THEN 

do; 

CALL put; 

RETURN PERIOD; 

end; 

IF LEFT$PAR IN THEN 

do; 

CALL put; 

RETURN LPARINJ 

end; 

I? RIGET$PAR IN THEN 

do; 

CALL PUT; 

RETURN RPARIN; 

end; 

do forever; 

CALL put; 

IF END$OF$TOKEN then return input$str; 

END; /* OF DO FOREVER */ 

END get$token; 

/* END OF SCANNER ROUTINES */ 

/* SCANNER EXEC */ 

SCANNER: PROCJ 

IF(TOKEN := GET$TOKEN ) = INPUT$STR THEN 

IF (CTR := RESERVED$WORD ) <> 0 THEN TOKEN = CTR; 

END scanner; 

PRINTSACCUM: PROC,* 

DCL I byte; 

DO I = 1 TO ACCUM(0); 

CALL PRINT$CHAR(ACCUM(I ) ) J 
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CALL WRlTE$TO$DISK(ACCUM( I) ) J 

end; 

call crlf; 
call dcrlf; 
end print$accum; 

PRI NT$ NUMBER : PROC(NUME); 

DECLARE ( NUMB , I , CNT,X) EYTE, J (*) EYTE DA TA ( 1 00 , 10 ) ; 
DO I = 0 TO i; 

CNT = 0J 

DO WHILE NUMB >= (X := J(I))J 
NUMB = NUMB - KJ 
CNT = CNT + i; 

end; 

CALL PRINTCEAR( '0' + CNT); 

end; 

CALL PRINTCEAR ( '0 ' + NUME) J 
END PRI NT$ NUMBER,* 

/* * * 5:5 END OF SCANNER PROCS * * * */ 



/* # # # 
DECLARE 


* SYMBOL 


TABLE DECLARATIONS * * * */ 


CUR$SYM 


ADDRESS 


, /^SYMBOL BEING ACCESSED*/ 


DECIMAL 


LIT 


'11', 


DISPLACEMENT 


LIT 


'14', 


FC3$ADDR 


LIT 


'4;, 


FLD$LENGTE 


LIT 


'3', 


HASH$MASX 


LIT 


'3FH ' , 


LEVEL 


LIT 


'10', 


LOCATION 


LIT 


'2', 


P$LENGTE 


LIT 


'3', 


REL$ID 


LIT 


'5', 


S$TYPE 


LIT 


'2', 


START$NAM.E 


LIT 


'13', /*! LESS*/ 


SYMBOL 


BASED CUR$SYM (l) BYTE, 


SYMBOL$ADDR 


BASED CUR$SYM (1) ADDRESS, 


TEMP$PTR 


ADDRESS 


» 


TEMP$ADDR 


BASED TEMP$PTR ADDRESS, 


/# # # # * 


* * SYMBOL 


TYPE LITERALS * * * * * * */ 


A $ED 


LIT 


'72' , 


A$N $ED 


LIT 


'73', 


ALPHA 


LIT 


'8', 


ALPHA$ NUM 


LIT 


'9', 


COMP 


LIT 


'21', 


CROUP 


LIT 


'6', 


LABEL^TYPE 


LIT 


'32' , 


LI T$OUOTE 


LIT 


'11', 


LIT$SPACE 


LIT 


'10' , 


LITiZERO 


LIT 


'12', 
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MULT^OCCURS 

NON$NUMERIC$LIT 

NUM$ED 

NUMERIC 

N UMERIC$ LITERAL 
UNRESOLVED 



LIT 

LIT 

LIT 

LIT 

LIT 

LIT 




/* * * * STMEOL TABLE ROUTINES * * * */ 

SET$ADDRESS : PROC(ADDR)? 

DCL ADDR ADDRESS? 

SYMBOL$ADDR ( LOCATI ON ) = ADDR? 

END SET$ADDRESS? 

GET$ADDRESS: PROC ADDRESS,* 

RETURN SYMBOL$ADBR ( LOCATION ) J 
END GET$ADDRESS5 

GET$FCB$ADDR : PROC ADDRESS ? 

RETURN SYMBOL$ADDR(FCB$ADDR) ? 

END get$fcb$addr; 

GET$TYPE: PROC BYTE? 

RETURN SYMBOL(S$TYPE); 

END get$type; 

SET$TYPF : PROC(TYPE); 

DCL TYPE BYTE; 

SYMBOL(S$TYPE ) = TYPE; 

END set$type; 

GET$LENGTE: PROC ADDRESS? 

RETURN SYM30L$ADDR(FLD$LENGTH) ? 

END get$length; 

GET$LEVEL: PROC BYTE? 

RETURN SYMBOL ( LEVEL ) ? 

END GET$LEVEL? 

GET$DECIMAL: PROC BYTE? 

RETURN SYMBOL (DECIMAL),* 

END GET$DECIMAL? 

GET$P$LENGTE : PROC BYTE? 

RETURN SYMBOL(P$LENGTE); 

END GET$P$LENGTH? 

BUILD$SYMBOL: PROC(LEN); 

DCL LEN BYTE, TEMP ADDRESS? 

TEMP = NEXT$SYM? 

IF (NEXT$SYM := .SYMBOL( LEN := LEN + DISPLACEMENT)) 
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> MA X$ MEMORY TEEN CALL FATAL $ ERROP ( 'ST ' ) J 
CALL FILL (TEMP , 0 , LEN ) ; 

END build$symbol; 

GET$?REV$CCCURS : PROC ADDRESS; 

TEMP^PTR = CUR$SYM + DISPLACEMENT + GET$P $LENC*TH >* 

RETURN TEMP$ADDR; 

END GET$PREV$ OCCURS; 

AND$OUT$OCCURS: PROC ( TYPE$I N ) BYTE; 

DCL TYPE$ IN BYTE; 

RETURN TY?E$ IN AND 1275 
END A ND$ OUT $ OCCURS > 

CHECK$UNRESOLVED: PROC; 

DCL (I,J) BYTE ,PTR ADDRESS , ADDR$PTR BASED PTR ADDRESS; 

PTR = HASH$TAB$ADDR J /*SET PTR TO FIRST EASE A DDR*/ 

DO I = 1 TO 645 

IF ADDP.$PTR<>0 TEEN 

do; 

cur$s ym = addr$ptr; 

DO WHILE CURSYMOe; 

IE GET$TYPE = UNRESOLVED TEEN 

do; 

CALL PRINT( .( 'UL $') ) ; 

DO J = 1 TO GETiP$ LENGTH? 

CALL PR IN T$CEAR( SYMBOL (STAR TSNAME * J))J 
CALL WRITE$TO$DISK ( SYMBOL (S TART$NAKE + J))J 

end; 

CALL crlf; 

CALL dcrlf; 

CALL INC$CTR( . ERRORS CTR (0 ) ) > 

end; 

CURSYM = SYMBOL$ADDR(0)J 

end; 

end; 

PTR = PTR + 2; 

end; 

end checksunresolved; 



/* * * * PARSER DECLARATIONS * * * */ 



DCL 

COMPILING 

CON $LENGTE 

COND$TYPE 

DISPLAY$FLAG 

HOLD$SEC$ADDR 

HOLDiSECTION 

IDSPTR 

I D$STACK ( 20 ) 



BYTE 


INI 


BYTE, 




BYTE, 




BYTE 


INI 


ADDRESS , 




ADDRESS , 




BYTE, 




ADDRESS , 





TIAL ( TRUE ) , 
TIAL(FALSE) , 
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(I,J,K) 


ADDRESS , 


L$ADDR 


ADDRESS , 


L$DEC 


BYTE, 


L$DEC$TEMP 


BYTE, 


L$LENGTH 


ADDRESS , 


L$TYPE 


BYTE, 


MP 


BYTE, 


MPP1 


BYTE, 


NEXT$ADDRESS 


ADDRESS 


NOLOOK 


BYTE 


PSTACKSIZE 


LIT 


SECTION$FLAG 


BYTE 


SP 


BYTE 


STATE 


ADDRESS 


STATESTACK (PSTACKSIZE) 


ADDRESS , 


SUB$ I ND 


BYTE 


VARC ( 100) 


BYTE, 


VALUE ( PSTACKSIZE) 


ADDRESS , 


VALUE2 ( PSTACKSIZE ) 


ADDRESS , 


WRITE$BEFORE 


BYTE 


WRI TE$AFTER 


BYTE 



/*INDICIES FOR THE PARSER*/ 



INITIAL(0), 

I NITIAL ( FALSE ) , 

'30', /* SIZE OF STACKS-/ 
INITIAL(0) , 

I NITIAL (255) , 

INITIAL (STARTS ) , 

/* SAVED STATES */ 
INITIAL(3 ) , 

/*TEMP CHAR STORE*/ 

/* TEMP VALUES */ 

/* VALUE2 STACK */ 

IN IT IA L ( FALS E ) , 

INITIAL (FALSE) , 



/* * * # * * v * CODE LITERALS * * * * * * * * * */ 

/* THE CODS LITERALS ARE BROKEN INTO GROUPS DEPENDING 
ON THE TOTAL LENGTH OF CODS PRODUCED FOR TEAT ACTION #/ 
/* LENGTH ONE */ 



ADD 


LIT 


X'’ 


/* 


ADD REGISTER 1 TO REGISTER 0 */ 


SUB 


LIT 


'2', 


/* 


SUBTRACT REGISTER 1 FROM REGISTER 0 */ 


MUL 


LIT 


'r ' 

^ 9 


/* 


MULTIPLY REGISTER 0 BY REGISTER 1 */ 


DIV 


LIT 


'4', 


/* 


DIVIDE REGISTER 0 BY REGISTER 1 #/ 


NEG 


LIT 


'5't 


/* 


NOT OPERATOR */ 


STP 


LIT 


'6 , 


/* 


STOP PROGRAM */ 


STI 


LIT 




/* 


STORE REGISTER 2 INTO REGISTER 0 */ 


EXT 


LIT 


's'. 


/* 


EXIT SUBROUTINE */ 




/* 


LENGTH 


TWO */ 


RND 


LIT 


'9', 


/* 


ROUND CONTENTS OF REGISTER 2 */ 




/* 


LENGTH 


THREE */ 


RET 


LIT 


'10', 


/* 


RETURN #/ 


CDS 


LIT 


' 11 ', 


/* 


CLOSE */ 


SER 


LIT 


'12', 


/* 


BRANCH ON SIZE ERROR */ 


BRN 


LIT 


'13', 


/* 


BRANCH */ 


OPN 


LIT 


'14', 


/* 


OPEN A FILE FOR INPUT */ 


OP1 


LIT 


'15', 


/* 


OPEN A FILE FOR OUTPUT */ 


0P2 


LIT 


;ie;, 


/* 


OPEN A FILE FOR BOTH INPUT AND OUTPUT */ 


RGT 


LIT 


17 , 


/* 


REGISTER GREATER THAN */ 


RLT 


LIT 


'18', 


/* 


REGISTER LESS THAN */ 


REQ 


LIT 


'19', 


/* 


REGISTER EQUAL #/ 


INV 


LIT 


'20', 


/* 


BRANCH IF INVALID-FILE-ACTION FLAG TRUE */ 


EOR 


LIT 


'21' , 


/* 


BRANCH ON END-OF-RECORDS FLAG */ 




/* 


LENGTE 


FOUR */ 
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PAG 


LIT 


'22 ' , 


/* 


CARRIAGE CONTROL FOR PRINTER OPERATION 


ACC 


LIT 


'23' , 


/* 


accept */ 


STB 


LIT 


'24', 


/* 


STOP WITH DISPLAY */ 


LDI 


LIT 


'25' , 


/* 


LOAD A CODE ADDRESS DIRECT */ 




/* 


LENGTH 


FIVE */ 


DIS 


LIT 


'26', 


/* 


DISPLAY */ 


DEC 


LIT 


'27' , 


/* 


DECREMENT COUNT AND BRAN CE IF ZERO */ 


STO 


LIT 


'28', 


/* 


STORE NUMERIC */ 


ST1 


LIT 


'29', 


/* 


STORE SIGNED NUMERIC LEADING */ 


ST2 


LIT 


'30', 


/* 


STORE SIGNED NUMERIC TRAILING */ 


ST3 


LIT 


'31' , 


/V 


STORE SEPARATE SIGN LEADING */ 


ST4 


LIT 


'32 ', 


/* 


STORE SEPARATE SIGN TRAILING */ 


ST5 


LIT 


'33' , 


/* 


STORE A PACKED NUMERIC FIELD */ 




/* 


LENGTH 


SIX */ 


LOB 


LIT 


'34', 


/* 


LOAD NUMERIC LITER/L 


LDI 


LIT 


'35', 


/* 


LOAD NUMERIC */ 


LD2 


LIT 


'36', 


/* 


LOAD SIGNED NUMERIC LEADING */ 


LB3 


LIT 


'37', 


/* 


LOAD SIGNED NUMERIC TRAILING */ 


LD4 


LIT 


'38' , 


/* 


LOAD SEPARATE SIGN LEADING */ 


LD5 


LIT 


'39' , 


/* 


LOAD SEPARATE SIGN TRAILING */ 


LD6 


LIT 


'40', 


/* 


LOAD A PACKED NUMERIC FIELD */ 




/* 


LENGTH 


SEVEN */ 


PER 


LIT 


'41', 


/* 


PERFORM */ 


CNU 


LIT 


'42', 


/* 


COMPARE NUMERIC UNSIGNED */ 


CNS 


LIT 


'43', 


/* 


COMPARE NUMERIC SIGNED */ 


CAL 


LIT 


'44', 


/* 


COMPARE ALPHABETIC */ 


RVS 


LIT 


'45', 


/* 


REWRITE SEQUENTIAL */ 


DLS 


LIT 


'46' , 


/* 


DELETE SEQUENTIAL V 


RDF 


LIT 


'47', 


/* 


READ A SEQUENTIAL FILE */ 


WTF 


LIT 


'4e;, 


/* 


WRITE A RECORD TO A SEQUENTIAL FILE */ 


RVL 


LIT 


49', 


/* 


READ A VARIABLE LENGTH FILE */ 


WVL 


LIT 


'50' , 


/* 


WRITE A VARIABLE LENGTH RECORD */ 




/* 


LENGTH 


NINE */ 


SCR 


LIT 


'51', 


/* 


CALCULATE A SUBSCRIPT */ 


SGT 


LIT 


'52', 


/* 


STRING GREATER THAN */ 


SLT 


LIT 


'53', 


/* 


STRING LESS TEAN */ 


SEQ 


LIT 


/r i ' 

54 , 


/* 


STRING EQUAL ^ / 


MOV 


LIT 


'55', 


/* 


MOVE */ 




/* 


LENGTH 


TEN 


1 #/ 


RRS 


LIT 


'56', 


/* 


READ RELATIVE SEQUENTIAL */ 


WP.S 


LIT 


'57', 


/* 


WRITE RELATIVE SEQUENTIAL */ 


RRR 


LIT 


'58', 


/* 


READ RELATIVE RANDOM */ 


WRR 


LIT 


'59', 


/* 


WRITE RELATIVE RANDOM */ 


RWR 


LIT 


'60', 


/* 


REWRITE RELATIVE 


BLR 


LIT 


'61', 


/* 


DELETE RELATIVE */ 




/* 


LENGTH 


ELEVEN */ 


MED 


LIT 


'62' , 


/* 


MOVE INTO AN ALPHANUMERIC EDITED FIELD 




/* 


LENGTH 


THIRTEEN */ 


MNE 


LIT 


'63' , 


/* 


MOVE INTO A NUMERIC EDITED FIELD #/ 


SBR 


LIT 


'64', 


/* 


SUBROUTINE CALL */ 



/* VARIABLE LENGTH */ 
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GDP 


LIT 


'65 ' , 


/* 


GO TO - DEPENDING ON 


PAR 


LIT 


'66' , 


/* 


PARAMETER LIST */ 




/* 


BUILD 


DIRECTING ONLY */ 


I NT 


LIT 


'67' , 


/ v 


INITIALIZE MEMORY */ 


BST 


LIT 


'68', 


/* 


BACK STUFF */ 


TER 


LIT 


'69' , 


/* 


TERMINATE BUILD */ 


SCD 


LIT 


'70'? 


/* 


START CODE */ 



/* * * * PARSER ROUTINES * * * * */ 

DIGIT: PROC (CHAR) BYTE? 

DCL CHAR BYTE? 

RETURN (CHAR <= '9') AND (CHAR >= '0'); 

END digit; 

LETTER: PROC (CHAR) BYTE; 

DCL CHAR BYTE? 

RETURN (CHAR >= 'A') AND (CHAR <= 'Z')? 

END letter; 

I NVALID$TYPE : PROC J 

CALL PRINT$ERR0R( 'IT')J 

end invalid$type; 

3YTE$0UT: PROC ( ONE $BYTE ) ; 

DCL ONE$BYTE BYTE; 

IF NO$CODE THEN RETURN? 

IF (OUTPUT$PTR := OUTPUT$PTR + 1) > OUTPUTiEND THEN 

do; 

call WRITE$OUTPUT( .output$buff, .OUTPUT$FCB); 
output$ptr = .output$buff; 

END f 

OUTPUT$CHAR = ONF$BYTE? 

END eyte$out; 

ADDR$OUT : PROC ( ADDR ) J 
DCL ADDR ADDRESS? 

CALL BYTE$OUT (LOW (ADDR) )? 

CALL BYTE$OUT(HIGH (ADDR))? 

END addr$out; 

I NC$COUNT : PROC(CNT); 

DCL CNT BYTE? 

IF(NEXT$AVAILABLE := NEXT$AVAI LABLE + CNT) 

> ,MAX$INT$MEM THEN CALL FATAL$ERROR ( 'MO ' ) ? 

END INC$COUNT? 

ONE$ADDR$OPP: PROC (CODE, ADDR) ? 

DCL CODE BYTE, ADDR ADDRESS? 

CALL BYTE$OUT ( CODE) ? 

CALL ADDR$OUT ( ADDR ) ? 

CALL INC$C0UNT(3) ? 
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END ONE$ADDR$OPP; 

MATCH: PROC ADDRESS! 

DCL POINT ADDRESS, COLLISION EASED POINT ADDRESS, 

(HOLD, I) BITE! 

I? VARC(0)>MAX$ID$LEN THEN VARC (0) = MAX$ ID$LEN ! 

HOLD = 0! 

DO I = 1 TO VARC(0)J 

HOLD = HOLD + VAP.C(I)! 

END! 

POINT = HASH$TAE$ADDR + SHL ( ( HOLD AND HAS H$MA SK ) , 1 ) ! 

DO FOREVER! 

IF COLLISION = 0 TEEN 
DO! 

CUR$SYM, COLLISION = NSXT$SYM! 

CALL BUILD$SYME0L(VARC(3) ) ! 

SYMEOL(P$LENGTE) = VARC(0)! 

DO I = 1 TO VARC(0)! 

SYMBOL (START$NAME + I) = VARC(I)! 

END! 

CALL S ET$ TYPE ( UNRESOLVED ) ! 

RETURN CUR$SYM! 

END! 

ELSE 

DO! 

CUR$SYM=COLLISION! 

IF (HOLD: =GET$P$ LENGTH ) =VARC (0 ) THEN 
DO! 

1 = 1 ! 

DO WHILE SYMBOL(START$NAME + I)= VARC(I); 
IF ( I : =1+1 ) >HOLD THEN 

RETURN (CUR$SYM := COLLISION); 

END! 

END! 

END! 

POINT = collision; 

END! 

END MATCH! 

SET$VALUE : PROC (NUMB); 

DCL NUMB ADDRESS! 

VALUE (MP) = NUME! 

END SET$ VALUE ! 

SET$VALUE2 : PROC(ADDR)! 

DCL ADDR ADDRESS! 

VALUE2 ( MP ) = ADDR! 

END SET$VALUE2! 

CHX$UD$VAR:PROC (PTR) ! 

DCL PTR BYTE! 
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CURS YM = VALUE (PTR)J 
IF GET$TYPE = UNRESOLVED THEN 
CALL PR IN T$ERRCR ( 'UD ' ) > 

end chk$ud$vah; 

SUB$CNT: PROC BYTE; 

IF ( SU3$ IND := SUB$IND + l) > 7 THEN 
SUB $ IND = 1 ; 

RETURN SUBSIND; 

end sub$cnt; 

CODE$BYTE : PROC (CODE); 

DCL CODE BYTE? 

CALL BYTE$OUT ( CODE ) J 
CALL I NC $ COUNT (1)5 
END CODE$3YTE; 

CODE$ADDRESS : PROC (CODE); 

DCL CODE address; 

CALL ADDR$OUT(CODE) ; 

CALL INC$C0UNT(2)J 
END CODE$ADDRESS J 

CON VERT$ INTEGER : PROC ADDRESS; 

DCL A byte; 

ACTR = 0; 

IF VARC(l) = '+' TEEN A = 2; ELSE A = 1J 
DO CTR = A TO VARC(0)J 

IF NOT DIGIT(VARC(CTR) ) THEN 

do; 

CALL PRINT$ERROR( 'NN ' ); 

RETURN A$CTRJ 

end; 

ELSE A$CTR = SHL(ACTR,3) + SHL(ACTR,l) + 

VARC (CTR) - '0'J 

end; 

RETURN ACTR; 

end convert$integer; 

BACKS TUFF: PROC (ADD1 ,ADD2) ; 

DCL ( ADD1 ,ADD2 ) ADDRESS; 

CALL BYTE$OUT(BST) J 
CALL ADDR$OUT(ADDl ) 5 
CALL ADDR$0UT(ADD2)J 
END BACKiSTUFFJ 

CHK$NXT$ SENTENCE : PROCJ 

IF NEXT$ADDRESS <> 0 TEEN 

do; 

CALL BA„CKSTUFF( NEXT S ADDRESS , NEXTSAVAI LAP LE ) 
NEXT$ADDRESS = 05 
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end; 

end chksnxtssentence; 

UNRES$BRANCH: PROC J 

CALL S ET $ VALUE (NEXT$ AVAILABLE +1); 

CALL ONE$ADDE$OPP(BRN,0); 

CALL SET $VALU£2 (N EXT $ AVAILABLE ) > 

END unres$bra.nch; 

BACKSCOND: PROC J 

CALL BACXSTUFE(VALUE(S? - 1 ) f NEXT $ AVAILABLE) J 

END bacx$cond; 

SETSBRANCH: PROC J 

CALL S ET $ VALUE (NEXT$ AVAILABLE ) 5 
CALL CCDE$ADDRESS(0); 

END SETSBRANCH J 

KEEP$VALUES : PROCJ 

CALL SETSVALUE(VALUE(SP) ) ; 

CALL SETS VA LUE2 ( VALUE2 ( S P ) ) » 

END KEEP$VALUESJ 

CARRAGES CONTROL: PROC? 

WRITES BEFORE , WRITES AFTER = FALSE; 

CALL CODE$BYTE(PAG) ; 

CALL C0DE$ADDRESS(GET$FC3$ADDR); 

CALL C ODE SB YTE (VALUE ( SP ) ) » 

END CARRAGE$CONTROL; 

STD$ATTRIBUTES: PROC(TYPE); 

DCL TYPE BYTE? 

CALL CODE$ ADDRESS ( GET$FCB$ ADDR ) ; 

CUR$S YN! = GET$ADDRESSJ 

CALL CODE$ADDRESS (GET$ADDRESS ) 5 

CALL CODE$ ADDRESS (GET$LENGTH); 

IF TYPE = 0 THEN RETURN; 

CURSSYM = getsfcbSaddr; 

CURSSYM = SYMBOL$ADDR(REL$ID); 

CALL CODES ADDRESS ( GET $ ADDRESS ) ; 

CALL CODES BYTF (GET$ LENGTH ) J 
END STDSATTRIBUTES; 

WRIT E$A$ RECORD: PROC; 

DCL TEMPSSYM ADDRESS J 

IF GETSLEVEL <> 1 THEN CALL PRIN?$ERROR ( 'WL ') J 
ELSE 

do; 

TEMPSSYM = CURSSYM; 

CURSSYM = getsfcbsaddr; 

IF (CTR := GETSTYPE) <> 1 AND 
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(VRITE$BEF0RE OR WRITE$AFTER) THEN 
CALL PRINT$ERROR( 'CC')J 
IF CTR = 1 THEN 

do; 

IF VRI TE$AFTER THEN CALL CARRAGE$ CONTROL 
CALL COEE$BYTE(VTF) J 
CALL STD$ AT TRIBUTES (0 ) ? 

IF WRITE$BEFORE THEN 

do; 

curssyk = get$fcb$addr; 

CALL CARRAGE$ CONTROL? 

end; 

end; 

ELSE IF CTR = 2 THEN 

do; 

CALL CODE$EYTE(WRS) ? 

CALL STD$AT TRIBUTES ( 1 ) ; 

end; 

ELSE IF CTR = 3 THEN 
DO? 

CALL CODE$BYTE(WRR) ? 

CALL STD$AT TRIBUTES (1 ) ; 

end; 

ELSE IF CTR = 4 THEN 

do; 

CALL C0DE$3YTE ( WVL ) * 

CALL CODE$ADDRESS (GET$FCB$ADDR) ? 

CUR$SYM = temp$sym; 

CALL CODE$ADDRESS(GET$ADDRESS )? 

CALL C ODE $ ADDRESS (GET$LEN GTH) ? 

end; 

ELSE CALL PRI NT TERROR ( 'FT ') ; 

end; 

end write$a$record; 

RFAD$A$FILE: PROC ? 

IF (CTR := GET$TYPE ) = 1 THEN 

do; 

CALL CODE$BYTE(RDF) ? 

CALL STD$ATTRIBUTES(0); 

end; 

ELSE IF CTR = 2 THEN 

do; 

CALL CODE$BYTE(RRS ) ? 

CALL STD^AT TRIBUTES ( 1 ) ? 

end; 

ELSE IF CTR = 3 THEN 

do; 

CALL CODE$BYTE(RRR) ? 

CALL STD$ATTRIBUTES(1 ) ; 
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ELSE IF CTR = 4 THEN 

do; 

CALL CODE$BTTE(RVL) J 

CALL CODE$ADDRESS(GET£FCB$ADDR); 

CALL CODE$ADDRESS(GET$LENGTE) ; 

CUR$SYM = GET^ADDRESS; 

CALL CODE$ADDRESS(GET$ADDRESS ) J 

end; 

ELSE CALL PR IN T$ERROR ( 'FT' ) J 

END read$a$file; 

ARITHMETIC$TYPE: PROC BYTE; 

IF ( ( L$TYPE := AN D$OUT$ OCCURS ( L$TYPE) ) >= 

NUKERIC$LITERAL) AND ( L$TYPE <= COMP ) THEN 
RETURN L$TYPE - NUMERICSLITERAL; 

IF L$TYPE = LIT$ZERO OR L$TYPE = ALPHA $NUM TEEN 
RETURN 0J 

CALL invalid$type; 

RETURN 0; 

END arithmetic$type; 

DELETE$A$FILE : PROC; 

IF (CTR := GET$TYPE) = 3 THEN 

do; 

CALL CODE$BYTE(DLR) ; 

CALL std$attributes(i); 

end; 

ELSE IF CTR = 2 THEN 

do; 

CALL CODEiBYTE(DLS) J 
CALL STD$ATTRIBUTES(0); 

end; 

ELSE CALL PRINTSERROR ( 'IT ' ) J 

END delete$a$file; 

REWRITE$A$RECORD : PROC,* 

IF GETiLEVEL <> 1 THEN CALL PR I NT $ ERROR ( 'WL ' ) ; 
ELSE 

do; 

curSsym = get$fcb$addr; 

IF (CTR := GET$TYPE ) = 3 THEN 

do; 

CALL CODE$BYTE(RWR)j 
CALL STD$ ATTRIBUTES ( 1 ) ; 

end; 

ELSE IF CTR = 2 THEN 

do; 

CALL CODE$BYTE(RWS) J 
CALL STD$ATTRIBUTES (0); 

end; 

ELSE CALL PRINT$ERROR( 'IT' ) J 
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end; 

end revrite$a$record; 

ATTRIBUTES: PROCJ 

CALL CODE$ ADDRESS (L$ADDR) J 
CALL CODE$BYTE(L$LENGTH) J 
CALL CODE$BYTE(L$DEC) J 

END attributes; 

LOAD$L$ID: PROC(S$PTR); 

dcl s byte ; 

IE ( (A$CTR := VALUE( S $PTR) ) <= NON $NUMERI C$LI T) OR 
(A$CTR = NUMERIC$LITERAL) THEN 

do; 

L$ADDR = VALCE2(SPTR)5 
L^LENGTH = CON $LENGTH ; 

L$T YPE = A$CTRJ 

IF A$CTR = NUP.ER I C$LI TERAL THEN 
L$DEC = L$DEC$TEMP J 
ELSE L$DEC = 0J 
RETURN J 

end; 

IE A$CTR <= LIT$ZERO THEN 

do; 

L$TYPE ,L$ADDR = A$CTRJ 
L$DEC = 0; 

L$LENGTH = 1J 

return; 

end; 

CUR$STK = VALUE(S$PTR) ? 

L$TYPE = GET$TYPEJ 
L$LENGTH = GET$LENGTH 5 
L$DEC = get$decimal; 

IE( L$ADDR := VALUE2(S$?TR) ) = 0 THEN 
L$ADDR = GET$ADDRESS; 

END load$l$id; 

LOAD$REG: PROC (REG$NO,PTR ) ; 

DCL (REG$NO ,PTR) BYTE; 

CALL LOAD$L$ID(PTR); 

CALL CODE$BYTE(LOD+ARITHMETlCiTYPE ) ) 

CALL attributes; 

CALL CODE$BYTE(REG$NO)J 

END load^reg; 

STORE$REG : PROC(PTR); 

DCL PTR BYTE? 

CALL LOAD$L$ ID (PTR ) J 

CALL CODE$BYTE ( STO + ARITHMETIC$TYPE - 1); 

CALL attributes; 
end storz$reg; 
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STORE$CONSTANT: PROC ADDRESS; 

IF( MAX$INT$MEM : = l“'AX$INT$MEM - VARC(0)) < NEXT* AVAILABLE 
TEEN CALL FATAL TERROR ('MO ') ,* 

CALL BYTE$OUT ( INT ) ; 

CALL ADDR$OUT(MAX$INT$MEM) J 

CALL ADDR$OUT (CON $LENGTH := VARC(0)); 

DO CTR = 1 TO con$length; 

CALL BYTE$OUT( VARC(CTR) ) ; 

end; 

return max$int$kem; 
end store$constant; 

NUMERIC^LIT: PROC BYTE? 

DCL CHAR BYTE; 

L$DEC$TEMP = 0»* 

DO CTR = 1 TO VAHC (0)5 

IF NOT( DIGIT(CHAR := VARC(CTR)) 

OR (CHAR = OR (CHAR = '+') 

OR (CHAR = THEN RETURN FALSE; 

IF CHAR = TEEN 

l$dfc$te^p=varc(0)-ctr; 

end; 

RETURN TRUE; 

fnd numeric$lit; 

ALPHA$LI T : PROC BYTE? 

DO CTR = 1 TO VARC(0) ; 

IF NOT( LETTER ( VARC ( CTR ) ) ) THEN RETURN FALSE? 

end; 

RETURN TRUE? 

END alpea$lit; 

ROUND$STORE: PROC? 

IF VALUE (SP ) <> 0 THEN 

do; 

CALL CODE$BYTE(RND) ; 

CALL CODE$BYTE(L$DEC) ? 

end; 

CALL STORFiREG (SP - 1); 

END round$store; 

ADD$SUB : PROC(INDEX); 

DCL INDEX BYTE? 

CALL LOAD$RSG ( 1 , SP - 1); 

CALL CODESBYTE ( ADD + INDEX); 

CALL ROUNDiSTORE? 

END add$sub; 

MULT$DI V : PROC(INDEX); 

DCL INDEX BYTE? 
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CALL LOAD$REG(0,MPPl) ? 

CALL LOAD$REG ( 1 , SP - 1)? 

CALL CODE$BYTE(MUL + INDEX)? 

CALL RCUNDSSTORE? 

END MULT$D I V ? 

CHECK$SUBSCRIPT : PROC? 

DCL (TEMP , TEMP $A DDR) ADDRESS? 

CUR$STM = VALUE(MP)? 

IF GET$TYPE < MULT$OCCURS THEN 
DO? 

CALL PRIN T$ERRCR( 'IS') ? 

RETURN? 

e n r j 

IF NUMERIC$LIT TEEN 
DO? 

TEMP$ADDR = GET$ADDRESS ? 

IF (TEMP := GET$PREV$OCCUP. S ) <> 0 THEN 
CUR$SYM = TEMP? 

CALL SET $VALUE2 

(TEMP$ADDR + (GET$LENGTE 515 (CONVERT$IN TEGFR - 1)))? 
RETURN? 

END? 

CALL ONE$ADDR$OPP ( S C R, GET $ ADDRESS ) ? 

IF (TEMP := GET$PREV$OCCURS ) <> 0 THEN 
CURSSYM = TEMP? 

CALL CODE$ADDRESS(GET$LENGTH) ? 

CUR$SYM = MATCH? 

IF ((CTR := GET$TYPE) < NUMERIC) OR (CTR > COMP) THEN 
CALL PR I NT$ERROR( 'TE') ? 

CALL CODE$ADDRESS(GET$ADDRESS ) ? 

CALL CODE$BYTE(C-ET$LENGTH) ? 

CALL C0DE$BYTE(SU3$CNT) ? 

CALL SET$VALUE2(SUB$IND) ? 

END CHECK$SUBSCR IPT? 

LOAD$LABEL: PROC? 

CUR$SYM = VALUE(MP) ? 

IF ( A$CTR := GETSADDRESS) <> 0 TEEN 

CALL BACK$STUFF(A$CTR,VALUE2(MP) ) ? 

CALL SET$ ADDRESS ( VALUE2 ( MP ) ) ? 

IF GET$TYPE <> UNRESOLVED THEN 
CALL PRINT$ERROR( 'DD') ? 

CALL SET$TYPE(LABEL$TYPE) ? 

IF ( A$CTR := GET$FCB$ADDR) <> 0 THEN 

CALL BACK$STUFF( A$CTR , NEXT$A VAI LABLE ) ? 

SYMBOLS A DDR (FCB^ADDR) = NEXT$AVA ILABLE ? 

CALL ONE$ADDR$OPP(RET,0) ? 

END LOAD$LABFL? 

LOA D$ S EC $ LABEL : PROC? 
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A$CTR = VALUE ( MP ) ? 

CALL SET$ VALUE (HOLDS SECTION ) ? 

HOLDSSECT ION = A$CTR? 

A$CTR = VALUE2 ( MP ) J 

CALL SET$VALUE2(E0LDSSEC$ADDR) ; 

HOLDSSEC $ADDR = ASCTR? 

CALL loadslabel; 
end load$sec$label; 

L A BEL $ADDR$ OFFSET: PROC ( ADDR , HOLD, OFFSET) ADDRESS ? 
DCL ADDR ADDRESS? 

DCL (EOLD, OFFSET, CTR) BYTE ? 

CUR$SYM = ADDR? 

IF( CTR := GET$TYPE) = LABEL$TYPE THEN 

do; 

IF HOLD THEN RETURN GET$ADDP.ESS J 
RETURN GET$FCB^ADDR; 

end; 

IF CTR <> UNRESOLVED THEN CALL INVALID$TYPE? 

IF HOLD THEN 

do; 

A $CTR = get$address; 

CALL SET$ADDRESS(NEXT$AVAILABLE + O-FFSET ) ; 
RETURN A$CTR; 

end; 

a$ctr = get$fcb$addr; 

symbol$addr(fcb$addr) = nextsavailable + offset; 

RETURN A$CTr; 

end label$ader$offset; 

LABEL$ADDR : PROC (ADDR, HOLD) ADDRESS? 

DCL ADDR ADDRESS, 

HOLD BYTE? 

RETURN LABEL$ADDR$OFFSET (ADDR, HOLD, 1); 

end labelSaddr; 

CODE$FORSDISPLAY : PROC (POINT); 

DCL POINT BYTE? 

CALL LOAD$L$ ID (POINT); 

CALL ONE$ADDR$OPP(DIS ,L$ADDR) J 
CALL CODE$BYTE(L$LENGTH) ? 

IF DISPLA Y$FLAG TEEN CALL CODE$BYTE (1 ) J 
ELSE CALL CODE$BYTE (0 ) ; 

DISPLAY$FLAG = FALSE? 

END codeSfor$display; 

A$AN $TYPE : PROC BYTE? 

RETURN (L$TYPE >= ALPHA) AND ( L$TYPE <= LITSQUOTE)? 
END A$AN$TYPE? 

NOT$INTEGER: PROC BYTE? 
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RETURN L$DEC <> 0? 

END not$integer; 

NUMERIC$TYPE : PROC BYTE? 

RETURN ( ( L$TYPE >= N UMER I C $ L I TERA L ) AND ( L$TY PE <= COMP)) 
OR ( L$TYPE=LIT $ZERO ) > 

END numeric$type; 

GEN$CCMPARE: PROCJ 

DCL (RETYPE, H$DEC ) BYTE , (H$ADDR ,H$LENGTH ) ADDRESS; 

CALL LOAD$L$ID(MP) ; 

L$TYPE = AND$OUT$OCCURS(L$TYPE) J 

IF COND$TYPE = 3 THEN /* COMPARE FOR NUMERIC */ 

do; 

IF L$TYPE = ALPHA OR ( L$TYPE > COMP) THEN 

CALL invalid$type; 

CALL SET$VALUE2( NEXT $ AVAILABLE ) ; 

IF L$TYPE = NUMERIC THEN CALL CODE$BYTE( CNU ) ; 

ELSE CALL CODE$BYTE ( C NS ) ; 

CALL CODE$ADDRESS(L$ADER) ; 

CALL C ODE $ ADDRESS ( L$ LENGTH) J 

CALL severance; 

end; 

ELSE IF CON D$TYPE = 4 THEN 

do; 

IF NUMERIC$TYPE THEN CALL INVALID$TYPE; 

CALL SET$VALUE2( NEXT $ AVAILABLE ) > 

CALL CODE$BYTE(CAL) J 

CALL COBE^ADBRESS ( L$ AEDR ) J 

CALL CODE$ADDRESS(L$LENGTH)? 

call set$branch; 

end; 
else do; 

IF NUMERIC$TYPE THEN CTR=i; 

ELSE CTR = 0; 

H$TYPE = L$TYPEJ 
H$DEC = L$DECJ 
H$ADDR = L$ADDRJ 
H$LENGTH = L$LENGTH; 

CALL LOAD$L$ID(SP); 

IF NUMSRICSTYPE THEN CTR = CTR + l; 

IF CTR = 2 TEEN /* NUMERIC COMPARE */ 

do; 

CALL LOAD$REG(0,MP) ; 

CALL S ET RVALUE 2 ( NEXT$ AVAILABLE - 6); 

CALL LOAD$REG(l ,SP) ,* 

CALL CODE^BYTE(SUB) ; 

CALL C0DE$3YTE(RGT + COND$TYPE); 

call set$bpanch; 

end; 
else do; 
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/* ALPHA NUMERIC COMPARE ***/ 

IF (E$TYPE = COMP) OR (L$TYPZ = COMP) THEN 

CALL invalid$type; 

ELSE IF (E$LENGTE <> L$LENGTH) TEEN 
IF NOT ( ( L$TYPE >= LIT$SPACE) ANL 
( L$TYPE <*= LIT$ ZERO ) ) XOR 
( ( H$TYPE >= LIT$SPACS) ANL 
(RETYPE <= LIT^ZERO ) ) THEN 

CALL invalid$type; 

ELSE IF (L$DEC <> 0) OR (E$DEC <> 0) THEN 
IF NOT ( ( L$TYPE = NUM$ED ) XOR 

(E$TY?E = NUMSED ) ) THEN 

CALL invalid$type; 

CALL set$value2(next$available) ; 

CALL CODE$BYTE(SGT+COND$TYPE); 

CALL C OLE $ ADDRESS ( H$ ADDR ) J 
CALL CODE$ADDRESS(L$ADDR)J 
CALL CCDE$ ADDRESS ( H$LENC-TE ) ; 

CALL set$branch; 

end; 

end; 

end gen$com.pare; 

MOVE$TYPF : PROC BYTE? 

DCL 

HOLD$TYPE BYTE, 



ALPHA$NUM$MOVE 


LIT 


'0'. 


A$N$ED$MOVE 


LIT 


' 1 ', 


NUMERI C$MOVE 


LIT 


'2', 


N$ED$MOVE 


LIT 


'3 ; 



L$TYPE = AN D $ OUT $ OCCURS ( L$TYPE ) J 

IF( (HOLD$TYPE := AND$OUT$OCCURS ( GFT$TYPE) ) = GROUP) OR 
( L$TYPE = GROUP) 

THEN RETURN ALPEA$NUM$MOVE ? 

IF EOLD$TYPE = ALPHA THEN 

IF A$AN$TYPE OR ( L$TYPE = A$ED ) OR (L^TYPE = AiN$ED) 
OR ( (ALPHA$LIT$FLAG ) AND 
(L$TYPE = NON$NUMERIC$LIT)) 

THEN RETURN ALPHA$NUM$MOVEJ 
IF HCLD$TYPE=ALPEA$NUM THEN 

do; 

IF NOT$INTEGER AND ( L$TYPE <> NUM$ED ) THEN 

CALL invalid$type; 

RETURN ALPHA$NUM$M0VE; 

end; 

IF ( EOLD$TYPE >= NUMERIC) AND (HOLD$TYPE <= COMP) TEEN 

do; 

IF (L$TYPE = ALPHA) OR (LSTYPE > COMP) TEEN 

CALL invalid$type; 

RETURN NUMERIC$MOVE; 

end; 
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IF HOLD$TYPE = A $N ?ED THEN 
DO * 

IF NOT?INTEGER AND ( L?TYPE <> NUM?ED) THEN 

call invalid$type; 

RETURN A?N?ED?MOVEJ 

end; 

IF HOLD?TY?E = A$ED THEN 

IF A$AN ?TYPE OR (L?TYPE > COMP) OR 
(L?TYPE = NON $NUMERIC$LIT ) 

THEN RETURN A?N?ED?MOVEJ 
IF HOLD$TY?E = NUMBED THEN 

I? NUMER I C$TYPE OR (L$TYPE = ALPHA $N UM ) THEN 
RETURN N?ED?MOVEJ 
CALL INVALID$TYPEJ 
RETURN 0J 

END move?type; 

GEN $MOVE : PROC J 

DCL ( ADDR1 , EXTRA .LENGTHl ) ADDRESS,* 

ADD?ADD?LEN: PROCJ 

CALL CODE? ADDRESS (ADDR1 ) 5 
CALL CODE$ADDRESS(L$ADDR) J 
CALL CODE? ADDRESS (L?LENGTH ) J 
END ADD$ADD$LENJ 

CODE?FOR?ED IT : PROCJ 
CALL add?add?len; 

CALL code?address(get?fce$addr) ; 

CALL CODE? ADDRESS ( LENGTH 1 ) j 
END CODE?FOR?EDITJ 

CALL LOAD?L?ID(MPPl); 

CUR?SYM=VALUE(SP)J 

IF (ADDR1 := VALUE2 ( S P ) ) = 0 THEN ADDR1 = GET ?ADDRESS 
LENGTH1 = GET?LENGTHJ 
DO CASE move?type; 

/* ALPHA NUMERIC MOVE */ 

do; 

IF LENGTHl > L?LENGTH THEN 

EXTRA = LENGTHl - L?LENGTHJ 
ELSE do; 

EXTRA = 0J 
L?LENGTH = LENGTHl; 

end; 

CALL CODE?BYTE(MOV) J 

CALL add?add?len; 

CALL CODE?ADDRESS (EXTRA ) ; 

end; 

/* ALPHA NUMERIC EDITED #/ 

do; 
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CALL CODE$BYTE(MSD) » 

CALL code$for$edit; 

end; 

/* NUMERIC MOVE */ 

do; 

CALL L0AD$REG(2,MPP1 ) J 
CALL STORE$REG(SP) J 

end; 

/* NUMERIC EDITED MOVE */ 

do; 

CALL C0DE$3YTE(MNE); 

CALL code$for$edit; 

CALL CODE$BITE(L$DEC); 

CALL CODE$BITE(GET$DFCIMAL) J 

end; 

end; 

end gen$move; 

COPE$GEN: PROC(PRODUCTION ) ; 

DCL PRODUCTION BYTE; 

IF PRINT$PROD THEN 

do; 

CALL crlf; 

CALL PRINTCHAR(POUND) ; 

CALL PRINT$NUMBER( PRODUCTION); 

END* 

do case’production; 

/* PRODUCTIONS*/ 

; /* CASE 0 NOT USED */ 

1 <P-DIV> ::= PROCEDURE DIVISION <USING> 

1 <PROC-BODY> 

E 0 J 

COMPILING = FALSE; 

IF SECT ION $FLAG THEN CALL LOAD$SEC $LA3EL i 

end; 

2 <US ING> ::= USING <ID-STRING> 

IF VALUE (MP - 1) = 0 THEN 

DO I = 0 TO id$ptr; 

CURSYM = ID$STACK(I); 

CALL SET$ADDRESS ( 13 + I)J 

end; 

ELSE 

do; 

CALL CODE$BYTE ( PAR ) ; 

CALL CODE$ADDRESS( ID$PTR +1); 

DO I = 0 TO id$ptr; 

CUR$SYM = ID$STACK(I); 

CALL CODE^ADDRESS(GET$ADDRESS ); 

end; 

end; 

/* 3 \ ! <EMPTY> 



/* 

/* 



/* 



*/ 

V 



*/ 
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J /» NO ACTION REQUIRED #/ 

/* 4 <ID-STRING> <ID> */ 

ID$STACK( ID$PTR := 0) = VALUE(SP); 

/# 5 \ ! <ID-STRING> <ID> */ 

EO * 

IF(ID$PTR := IDPTR + 1 ) = 20 TEEN 

do; 

CALL PRIN T$ERROR ( 'ID') ; 

ID$PTR=19; 

end; 

ID$STACK(ID$PTR)=VALUE(SP); 

end; 



/* 


6 


<PROC-BODT> <PARAGRAPE> 


*/ 




; /* 


NO ACTION REQUIRED */ 




/* 


7 


\ ! <PROC-BODY> <PARAGRAPH> 


*/ 




; /* 


NO ACTION REQUIRED */ 




/* 


8 


<PARAGRAPH> ::= <ID> . 


*/ 




; /* 


NO ACTION REQUIRED */ 




/* 


9 


\! <ID> . <S ENTENC E-LI ST> 


*/ 




do; 








IE SECTION $FLAG = 0 THEN SECTION$ELAG = 2* 






CALL 


, load$label; 






end; 






/* 


10 


\! <ID> SECTION . 


*/ 




do; 







IE SECT ION $ EL AGO 1 THEN 

do; 

IE SECTION$ELAG = 2 THEN 

CALL PRI NT$ERR0R ( 'PF') J 
SECTION $FLAG = 1,* 

HOLD$SSCTION = VALUE(MP); 

HOLD$SEC$ADDR = VALUE2(MP); 

end; 

ELSE CALL LOAD$SEC$LABEL; 

end; 

/* 11 <SENTENCE-LIST> <SENTENCE> . #/ 

CALL chk$nxt$sentence; 

/* 12 \ ! <SENTEN CE-L I ST> */ 

/* 12 <SENTENCE> . */ 

CALL chk$nxt$sentence; 

/* 13 <S EN TEN CE> ::= <IMPERATIVE> #/ 

; /* NO ACTION REQUIRED */ 

/* 14 \ ! <CONDITIONAL> */ 

J /* NO ACTION REQUIRED */ 

/* 15 \ ! ENTER <ID> <OPT-ID> */ 

CALL PRI NT$ ERROR ( 'N I ' ) ; 

/* 16 <1 MPERAT I VE> ::= ACCEPT <SUBID> */ 

do; 

CALL LOAD$L$ID(SP) ; 

CALL ONE$ADDR$OPP(ACC,L$ADDR) J 
CALL CODE$BYTE(L$LENGTH); 
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end; 

/* 1? \ ! <ARITHMETIC> */ 

; /* NO ACTION REQUIRED */ 

/* 18 \! CALL <CALL-LIT> <USING> */ 

do; 

CURS YM = VALUE(MPPl); 

CALL CODE$BYTE(SBR) ; 

do i = i to e; 

IF I <= GET$P$LENGTH THEN 

CALL BYTE$OUT ( SYMBOL ( ST ART $ NAME + I)}; 

ELSE CALL BYTE$OUT(20H)J 

end; 

CALL INC$C0UNT(6) ; 

end; 

/* 19 \! CLOSE <CLOSE-LST> */ 

do; 

DCL TYPE BYTE; 

IF ((TYPE := GET$TYPE) > 0) AND (TYPE < 5) THEN 
CALL ONE$ADDR$OPP(CLS ,GET$FCB$ADDR ) ; 

ELSE CALL PRINT$ERR0R( 'CE ' ) > 

end; 

/* 19 \! <F I LE-AC T> */ 

; /* NO ACTION REQUIRED */ 

/* 21 \! DISPLAY <DISPLAY-LST> */ 

J /* NO ACTION REQUIRED */ 

/* 22 \! DISPLAY <DISPLAY-LST> WITH */ 

/* 22 NO ADVANCING */ 

; /* NO ACTION REQUIRED-NOT IMPLEMENTED */ 

/* 23 \ ! EXIT <PROGRAM-ID> */ 

CALL CODE$BYTE(EXT); 

/* 24 \! GO <ID> */ 

CALL ONE$ADDR$OPP (BRN f LABEL$ADDR (VALUE (SP ) , 1 ) ) J 
/* 25 \ ! GO <ID-STRINC-> DEPENDING */ 

/* 25 <ID> */ 

do; 

CALL CODE$BYTE(GDP); 

CALL CODE$BYTE( ID$PTR +1); 

CUR$S YM = VALUE ( SP ) ; 

CALL CHK$UD$VAR(SP); 

CALL CODE$BYTE(GET$LENGTH ) J 
CALL CODE$ADDRESS(GET$ADDRESS); 

DO CTR = 0 TO IDSPTR; 

CALL CODE$ADDRESS 

( LABEL $A DDR $ OFF SET (ID$STACK(CTR),1,0) ) ; 

end; 



end; 



/* 


26 


\ ! 


MOVE 


<LIT/ID> TO <SUBID> 






CALL gen$move; 










/* 


2? 


\! 


OPEN 


<AC T-L ST> 


*/ 




; /* NO ACTION 


REQUIRED 


*/ 






/* 


28 


\ ! 


PERFORM <ID> <TERU> <JINISH>*/ 
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do; 

DC L ( ADDR2 ,ADDR3 ) ADDRESS,* 

IF VALUE (SP - 1) = 0 TEEN 

A DDR 2 = L ABEL $ ADDR$ OFES ET (VALUE (MP Pi ) ,0 ,3 ) J 
ELSE ADDR2 = LA PELS ADDRSOFFSET ( VALUE ( SP-1 ) , 0 , 3 ) J 
IF ( ADDR2 := VALUE2(SP)) = 0 TEEN 
A DDR 3 = NEXT$ AVAILABLE + 7J 
ELSE CALL BACKSTUFF (VALUE ( S P ), NEXT SAVA ILA PLE + 7); 
CALL ON E$ADDR$OPP( PER, LABELS A DDR (VALUE (MPP1 ) ,1) ) T 
CALL CODE$ADDRESS (ADDR2) J 
CALL C0DF$ADDRESS(ADDR3) ; 

end; 

/* 29 \ ! STOP <TERMINATE> */ 

do; 

IF VALUE ( SP ) = 0 TEEN CALL CODESBYTE ( STP ) ; 

ELSE IF (VALUE(SP) < LITSSPACE) OR 
( VALUE ( SP ) > LI TS ZERO ) THEN 

do; 

CALL 0NE$ADDR$0PP(STD,VALUE2(SP)) ,* 

CALL CODE$BYTE( CONSLENGTH ) J 

END ; 

ELSE 

do; 

CALL ON ES ADDR$OPP( STD ,VALUE(SP) )J 
CALL CODESBYTE(l) ; 

end; 

end; 

/* 30 <CLOSE-LST> <ID> */ 

,* /* NO ACTION REQUIRED */ 

/* 31 \ ! <CLOSE-LST> <ID> */ 

J /* NO ACTION FEQUIRED-NOT IMPLEMENTED */ 

/* 32 <DISPLAY-LST> : := <LIT/ID> */ 

CALL CODE$FOR$DISPLAY(SP); 

/* 33 \ ! <D IS PLAY-LS T> <LIT/ID> */ 

do; 

DISPLAY$FLAG = TRUE? 

CALL CODES FOR $DIS PL AY( SP) j 

end; 

/* 34 <ACT-LST> ::= <TYPE-ACTION> <OPEN-LST> */ 

do; 

DC L TYPE BYTE? 

TYPE = get$type; 

IV (TYPE = 1 OR TYPE = 4) AND (VALUE(MP) <> 2) THEN 
CALL ONESADDRSOPP(OPN + VALUE ( MP ) , GET SEC BS A DDR ) ; 

ELSE 

IE (TYPE = 2 OR TYPE = 3) THEN 

CALL ONE$ADDR$OPP(OPN + VALUE (MP) ,GETSFCESABDR ) ; 
ELSE CALL PRINTSERROR ( 'OE ' ) ; 

end; 

/* 35 \ ! <ACT-LST> <TYPE-ACTION> */ 

/* 35 <OPEN-LS T> */ 
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/» NO ACTION REQUIRSD-NOT IMPLEMENTED */ 



/* 


36 


<OPEN-LST> : := <ID> 


*7 




T /* 


NO ACTION REQUIRED */ 




/* 


37 


\ ! <0PEN-LST> <ID> 


*/ 


; /* 


NO ACTION REQUIRED-NOT IMPLEMENTED */ 




/* 


38 


<EIN ISH> ::= <L/ID> TIMES 


*/ 




do; 








CALL 


LOADiL$ID(MP) ; 






CALL 


0NE$ADDR$0PP(LDI ,L$ADDR) ; 






CALL 


CODE$BYTE(L$LENGTE) ; 






CALL 


SETiVALUE2(NEXT$AVAlLABLE) ; 






CALL 


CNE$ ADDR$OPP ( EEC , 0 ) ; 






CALL 


SET$VALUE(NEXTHVAILABLE) J 






CALL 


C0DE$A DURESS ( 0 ) J 






end; 






/* 


39 


\ ! <ST0PC0NDITI0N> 


*/ 




CALL KEEP$VALUES; 




/* 


40 


\ ! <VARYINC> ^ITERATION > 


* / 


/* 


40 


<STOPCONDITION> 


*/ 




CALL KEEP$VALUES; 




/* 


41 


\t <EMPTY> 


*/ 




; /* 


NO ACTION REQUIRED */ 




/* 


42 


<ST0PC0NDITI0N> ::= UNTIL <CONDITION> 


*/ 




CALL KEEPSVALUES; 




/* 


43 


<VARYING> ::= VARYING <SU3ID> 


*/ 




CALL KEEP^VALUESJ 




/* 


44 


<ITERATION> ::= <FR0M> <BY> 


*/ 




; /* 


NO ACTION REQUIRED */ 


• 


/* 


45 


<FROM> ::= FROM <L/ID> 


*/ 




do; 








CALL L0AD$REG(2 t SP) ; 
CALL STORE$REG(MP - 1); 






end; 






/* 


46 


<BY> ::= BY <L/ID> 


*/ 




• 

o 

o 







CALL LOAD$REG (0 ,MP - 2); 
CALL LOAD$REG ( 1 , SP ) > 

CALL CODE$PYTE( ADD) » 

CALL STORE$REG(MP - 2); 

END ; 



/* 


47 <C0NDIT ION AL> 


• • 


<ARI THMETI C> <SIZE-ERRCR> */ 


/* 


47 

call back$cond; 




<IMPERATIVE> 


*/ 


/* 


48 


\ ! 


<FILE-ACT> <INVALID> 


*/ 


/* 


48 

call bacx$cond; 




<IMPERAT I VE> 


*/ 


/* 


49 


\! 


<READ-ID> <SPECIAL> 


*/ 


/* 


49 

call back$cond; 




<IMPERATIVE> 


*/ 


/* 


50 


\! 


<IF-NONTERMINAL> 


*/ 


/* 


50 




<C0NDIT ION > <IF-LST> 


<ELSE>*/ 
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50 



<IF-LST> END-IF 



/* 



/* 

/* 

/* 

/* 

/* 



/* 



/* 

/* 

/* 

/* 



/* 

/* 

/* 

/* 

/* 

/* 

/* 

/* 

/* 

/* 

/* 

/* 

/* 

/* 



565 / 



do; 

CALL BACKSTUFF( VALUE (MPP1 ) ,VALUE2(SP - 3)); 

CALL BACKS TUFF ( VALUE ( SP - 3) , NEXT$AVAILABLF) ; 

end; 

51 \ ! <IF-NONTERMINAL> */ 

51 <COND IT ION> */ 

51 <IF-LST> END-IF */ 

CALL BACKS TUFF (VALUE ( MPP1 ) ,NEXT$AVAILAELE ) J 

52 <IF-LST> : <STMT-LST> */ 

; /* NO ACTION REQUIRED */ 

53 \! NEXT SENTENCE */ 

do; 

CALL ONE$ADDR $OPP (BRN , NEXT$ADDP.ESS ) ; 

NEXT$ADDRESS = NEXT$ AVAILABLE - 2; 

end; 

54 <ELSE> ::= ELSE */ 

do; 

VALUE( S P - 1) = NEXT$AVAILABLE + 1J 
CALL ONE$ADDR$OPP(BRN,0) ; 



VALUE2 (SP - 1) = 


next$available; 




end; 


55 <ARITHMETIC> 


::= ADD <ADD-LST> TO <SUBID> 


*/ 


55 


<ROUND> 


*/ 


CALL ADD$SUB(0); 


56 


\! ADD <ADD-LST> GIVING <SUBID>*/ 


56 


<ROUND> 


*/ 


do; 


IF VALUE (MP ) = 0 


then call print Terror ( 'ig' ) ; 




CALL round$store; 

end; 


57 


\ ! DIVIDE <L/ID> INTO <SUBID> 


*/ 


57 


<ROUND> 


*/ 


CALL MULT$DIV(1); 


58 


\ ! DIVIDE <L/ID> BY <SUBID> 


*/ 


58 


GIVING <SUE ID> <ROUND> 


*/ 


CALL PRINT$ERROR( 'NI ' 


); 




59 


\ ! DIVIDE <L/ID> INTO <SUBID> 


*/ 




GIVING <SUBID> <ROUND> 


*/ 


CALL PRINT$ERROR( 'NI' 


); 




60 


\ ! MULTIPLY <L/ID> BY <SUBID> 


V 


60 


<ROUND> 


*/ 


CALL MULT $D IV ( 0 ) J 


61 


\ ! MULTIPLY <L/ID> BY <SUBID> 


V 


61 


GIVING <SUB ID> <ROUND> 


*/ 


CALL PRINT$ERROR( 'NI ' 


); 




62 


\! SUBTRACT <SUB-LST> FROM 


*/ 


62 


<SUB ID> <ROUNL> 


*/ 


CALL ADD$SUB(1); 


63 


\ ! SUBTRACT <SUB-LST> GIVING 


*/ 


63 


<SUE ID> <ROUND> 


*/ 
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do; 





IF VALUE(MP) = 0 THEN CALL PRINT$ ERROR ( 'IG ' ) » 






CALL 


round$store; 






end; 






/* 


64 


\ ! COMPUTE <SUBID> = <ARITH- 


-EXP>V 




CALL PRINT$ ERROR ( 'N I ' ) ; 




/* 


65 


<ADD-LST> ::= <L/ID> 


*/ 




CALL LOAD$REG(0,SP) J 




/* 


66 


\ I <ADD-LST> <L/ID> 


*/ 




do; 








CALL 


LOAD$REG( 1 ,SP ) J 






CALL 


CODE$BYTE( ADD) ; 






CALL 


CODE$BYTE(STI ); 






VALUE (MP - 1) = lj 






end; 






/* 


67 


<SUB-LST> ::= <L/ID> 


*/ 




CALL LOAD$REG(0,SP) ; 




/* 


68 


\! <SUB-LST <L/ID> 


*/ 




do; 








CALL 


LOAD$REG ( 1 ,SP ) J 






CALL 


CODE$BYTE ( ADD ) J 






CALL 


code^byte(sti); 






VALUE (MP - 1) = lj 






end; 






/* 


69 


<ARITH-EXP> ::= <TERM> 


V 




; /* 


NO ACTION REOUIRED-NOT IMPLEMENTED */ 




/* 


70 


\! <ARITH-EXP> + <TERM> 


*/ 




; /* 


NO ACTION REQUIRED-NOT IMPLEMENTED */ 




/* 


71 


\! <ARITH-EXP> - <TERM> 


*/ 




; /* 


NO ACTION REQUIRED-NOT IMPLEMENTED */ 




/* 


72 


\ ! + <TERM> 


*/ 




; /* 


NO ACTION REQUIRED-NOT IMPLEMENTED */ 




/* 


73 


\ ! - <TERM> 


*/ 




; /* 


NO ACTION REQUIRED-NOT IMPLEMENTED */ 




/* 


74 


<TERM> ::= <PRIMARY> 


*/ 




; /* 


NO ACTION REQUIRED-NOT IMPLEMENTED */ 




/* 


75 


\ I <TERM> * <PPIMARY> 


*/ 




; /* 


NO ACTION REOUIRED-NOT IMPLEMENTED */ 




/* 


76 


\ ! <TERM> / <PRIMARY> 


*/ 




; /* 


NO ACTION REQUIRED-NOT IMPLEMENTED */ 




/* 


77 


<PR IMARY> ::= <PRIM-ELEM> 


*/ 




; /* 


NO ACTION REQUIRED-NOT IMPLEMENTED #/ 




/* 


78 


\! <PRIMARY> ** <PRIM-ELEM> 


*/ 




; /* 


NO ACTION REQUIRED-NOT IMPLEMENTED */ 




/* 


79 


<PRIM-ELEM> : := <L/ID> 


*/ 




; /* 


NO ACTION REQUIRED-NOT IMPLEMENTED */ 




/* 


80 


\ ! ( <ARITH-EXP> ) 


*/ 




; /* 


NO ACTION REQUIRED-NOT IMPLEMENTED */ 




/* 


81 


<FILE-ACT> ::= DELETE <ID> 


*/ 




CALL delete$a$file; 




/* 


82 


\! REWRITE <ID> 


*/ 
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CALL rewrite$a$record; 



/* 




B3 


\! WRITE <ID> <SPECIAL-ACT> 


*/ 




CALL write$a$record; 




/* 




94 


<C0NDITI0N> ::= <ETERM> 


*/ 




• 

* 


/* 


NO ACTION REQUIRED */ 




/* 




85 


\! <C0NDITI0N> OR <BTFRM> 


*/ 




• 

f 


/* 


NO ACTION REQUIRED-NOT IMPLEMENTED */ 




/* 




86 


<3TERM> ::= <BPRIM> 


*/ 




• 

f 


/* 


NO ACTION REQUIRED */ 




/* 




87 


\I <BTERM> AND <BPIRM> 


*/ 




• 

f 


/* 


NO ACTION REQUIRED-NOT IMPLEMETED */ 




/* 




88 


<BPRIM> : := <LIT/ID> 


*/ 




• 

» 


/* 


NO ACTION REQUIRED */ 




/* 


o 


89 


\ ! <LI T/ID> <NOT> <C0ND-TTPE> 


*/ 






IE 


IF$FLAG TEEN 










do; 










IF$FLAG = NOT IF$FLAG ; /* RESET I F$FLAG 
CALL C0DE$3YTE(NEG)J 


* / 








end; 





call gen$compare; 



/* 


end; 

90 


\! ( <BTERM> ) 


V/ 


/* 


; /* NO ACTION REQUIRED-NOT IMPLEMENTED 

91 <COND-TYPE> ::= NUMERIC 


*/ 

*/ 


/* 


COND$TYPE = 3J 
92 


\ ! ALPHABETIC 


*/ 


/* 


COND$TYPE = 4J 
93 


\ ! <COMPARE> <LIT/ID> */ 


/* 


CALL KEEP$VALUES; 
94 <NOT> :: = 


NOT 


*/ 


/* 


IF NOT IF$FLAG THEN 

CALL CODE$BYTE(NEG); 

ELSE IF$FLAG = NOT IF$FLAG > /* 

95 \ ! <EMPTY> 


RESET IF$FLAG : 
*/ 


/* 


; /* NO ACTION 

96 <COMPARE> 


REQUIRED */ 

: GREATER 


*/ 


/* 


CONDiTYPE = 0J 
97 


\ ! LESS 


*/ 


/* 


COND$TYPE = l; 
98 


\! EQUAL 


V 


/* 


CONDSTYPE = 2J 
99 


\! > 


*/ 


/* 


CONDiTYPE = 0J 
100 


\! < 


*/ 


/* 


COND$TYPE = l; 
101 


\ ! = 


*/ 


/* 


COND$TYPE = 2J 

102 <ROUND> : 


:= ROUNDED 


*/ 


/* 


CALL SET$ VALUE ( 1 ) J 
103 


\ ! <EMPTY > 


*/ 
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• 

f 


/* 


NO ACTION REQUIRED ^ / 




/* 




104 


<TERMINATE> ::= <LITERAL> 


V 




• 

> 


/* 


NO ACTION REQUIRED */ 




/* 




105 


\ I RUN 


*/ 




• 

j 


/* 


NO ACTION REQUIRED - VALUE(SP) ALREADY ZERO 


*/ 


/* 




106 


<SPEC IAL> <INVALID> 


*/ 




• 


/* 


NO ACTION REQUIRED #/ 




/* 




107 


\ ! END 


*/ 




do; 












CALL 


SET$VALUE ( 2 ) ; 








CALL 


CODE$BYTE(EOR) ; 








CALL 


set$branch; 






END 


• 

1 






/* 




108 


<OPT-ID> : := <SUBID> 


*/ 




• 

f 


/* 


VALUE AND VALUE2 ALREADY SET */ 




/* 




109 


\ ! <EKPTY> 


*/ 




• 

1 


/* 


VALUE ALREADY ZERO */ 




/* 




110 


<STMT-LST> ::= <IMPERATIVE> 


*/ 




• 

f 


/* 


NO ACTION REQUIRED */ 




/* 




111 


\! <STMT-LST> <IMPERATIVF> 


V 




• 

> 


/* 


NO ACTION REQUIRED */ 




/* 




112 


\! <CONDITIONAL> 


V 




• 

f 


/* 


NO ACTION REQUIRED */ 




/* 




113 


\! <STMT-LST> <CONDITIONAL> 


*/ 




• 

> 


/* 


NO ACTION REQUIRED */ 




/* 




114 


<THRU> ::= THRU <IB> 


*/ 




CALL KEEP$VALUES; 




/* 




115 


\ ! <EMPTY> 


V 




• 


/* 


NO ACTION REQUIRED */ 




/* 




116 


<IN VALID> ::= INVALID 


*/ 



do; 

CALL SET$VALUE(1) ; 

CALL CODE$BYTE(INV); 

CALL set$branch; 

end; 

/* 117 <SIZE-ERROR> SIZE ERROR */ 



/* 

/* 

/* 

/* 

/* 

/* 



do; 

CALL CODE$BYTE(SER); 

CALL unres$branch; 

end; 

lie <SPECIAL-ACT> ::= <WHEN> ADVANCING <EOW-MANY> */ 



CALL XEEP$VALUES; /* CARRAC-E CONTROL */ 

119 \ ! <EMPTY> */ 

J /* NO ACTION REQUIRED */ 

120 <¥HEN > ::= BEFORE */ 

WRI TE$BEEORE = TRUE; /* CARRAGE CONTROL */ 

121 \ ! AFTER */ 

VRITE$AFTER = TRUE; /* CARRAGE CONTROL */ 

122 <HOW-MANY> ::= <INTEGER> */ 

5 /* NO ACTION REQUIRED */ 

123 \ I PAGE */ 
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CALL SET?VALUE(101); /* CAHHAGE CONTROL */ 

/* 124 <TYPE-ACTION> : := INPUT */ 

; /* NO ACTION REQUIRED - VALUE(SP) ALREADY ZERO */ 

/* 125 \! OUTPUT #/ 

CALL SET? VALUE ( 1 ) J 

/* 126 \ l 1-0 */ 

CALL SET?VALUE(2 ) » 

/* 127 <SUBID> ::= <SUBSCRIPT> */ 

; /* VALUE AND VALUE2 ALREADY SET */ 

/* 128 \! <ID> */ 

CALL CHK?UD?VAR(SP); 

/* 129 <INTEGER> ::= <INPUT> */ 

CALL SET?VALUE(CONVEFT?INTEGER) ; 

/* 130 <ID> <INPUT> */ 

do; 

CALL SET? VALUE ( MATCH ) J 
IE GET?TYPE = UNRESOLVED THEN 

CALL SET$VALUE2(NEXT$AVAILABLE) ; 

end; 

/* 131 <L/ID> ::= <INPUT> #/ 

do; 

IF NUMERIC?LI T THEN 

do; 

CALL SET$VALUE(NUMERIC$LITERAL) ; 

CALL SET? VALUE 2 ( STORE? CON STAN T ) J 

end; 

ELSE 

do; 

CALL SET? VALUE ( MATCH ) ; 

CALL CEK?UD?VAR(MP) ; 

END ; 

end; 

/* 132 \ ! <SUBSCRIPT> */ 

; /* NO ACTION REQUIRED */ 

/* 133 \ ! ZERO */ 

CALL SET?VALUE(LIT?ZERO) ; 

/* 134 <SUBSCRIPT> ::= <ID> ( <SU3SCRIPT-LST> ) V 

CALL CHECKiSUBSCRIPT; 

/* 135 <SUBSCRIPT-LST> ::= <INPUT> */ 

; /* NO ACTION REQUIRED */ 

/* 136 \ ! <SUBSCR IPT-LST> , <INPUT> */ 

CALL PRINT? ERROR ( 'N I ' ) ; 

/* 137 <C ALL-LI T> ::= <LIT> */ 

CALL SET?VALUE(MATCH) J 

/* 138 <NN-LIT> ::= <LIT> */ 

do; 

ALPHA?LIT?FLAG = ALPHA?LIT ; 

CALL SET ? VALUE (N ON ?NUMERIC? LIT ) ; 

CALL SET?VALUE2(ST0PE?C0NSTANT) ; 

end; 

/* 139 \! SPACE */ 



265 



CALL SET$VALUE(LIT$SPACE)» 

/* 140 \ ! QUOTE */ 

CALL S ET $ VALUE (LI T$QUOTE) J 

/* 141 <LITERAL> ::= <NN-LIT> */ 

J /# NO ACTION REQUIRED */ 

/* 142 \ ! <INPUT> */ 

do; 

IE NOT NUMER IC $LIT THEN CALL INVALID $TYPEJ 
CALL SET$VALUE(NUMERIC$LITERAL) J 
CALL SET$VALUE2(ST0RE$C0NSTANT) J 

END » 

/* 143 \ ! ZERO */ 

CALL SET$VALUE(LIT$ZERO) ; 

/* 144 <LIT/ID> ::= <L/ID> */ 

; /* NO ACTION REQUIRED */ 

/* 145 \! <NN-LIT> */ 

; /* NO ACTION REQUIRED */ 

/* 146 <PROGRAM-ID> ::= <IE> */ 

CALL CODE$BYTE(EXT); 

/* 14? \ ! <EMPTY> */ 

; /* NO ACTION REQUIRED */ 

/* 148 <READ-ID> READ <ID> */ 

CALL read$a$file; 

/* 149 <IE-NONTERMINAL> : := IE */ 

I?$FLAG = TRUE? /* SET IF$FLAG */ 

END? /* END OF CASE STATEMENT */ 

END code$c-en; 

GETIN1: PROC address; 

RETURN INDEX1 (STATE); 

END GETINi; 

GETIN2: PROC BYTE? 

RETURN I NDEX2 (STATE ) J 
END GETIN2J 

INCSP: PROC; 

VALUE ( SP := SP + 1 ) t VALUE2(SP) = 0j /* CLEAR THE STACK */ 
IE SP >= PSTACKSIZE THEN CALL FA TAL$ ERROR ( 'SO ' ) ; 

END INCSP? 

LOOKAHEAD: PROC? 

IF NOLOOK THEN 

do; 

call scanner; 
nolook = false; 

IF PRINT$TOKEN THEN 

do; 

call crlf; 

CALL PRINT$NUMBER (TOKEN ); 

CALL PRI NT$CHAR ( ' '); 



266 



CALL print$accum; 



end; 

end; 

end lookahead; 

NO$CONFLICT : PROC (CSTATE ) BITE; 

DCL (CSTATE, I, J,K) ADDRESS; 

J = I NDEX1 (CSTATE ) J 
K = J + INDEX2 ( CSTATE ) - 1? 

DO I = J TO k; 

IP READl(I) = TOKEN THEN RETURN TRUE; 

end; 

RETURN FALSE; 

END NO$CONFLICTJ 

RECOVER: PROC BYTE; 

DCL TSP BYTE, RSTATE ADDRESS? 

DO forever; 
tsp = sp; 

DO WHILE TSP <> 255? 

IF N 0$ CON FLICT ( RSTATE := STATES TA CK ( TSP) ) THEN 
DO? /* STATE WILL READ TOKEN */ 

IF SP <> TSP THEN SP = TSP - 1? 

• RETURN RSTATE? 

end; 

TSP = TSP - i; 

end; 

CALL SCANNER; /* TRY ANOTHER TOKEN */ 

end; 

end recover; 

/* * * * * PROGRAM EXECUTION STARTS HERE * * */ 

/* INITIALIZATION */ 

TOKEN = 80J /* PRIME TEE SCANNER WITE -PROCEDURE- */ 

CALL M0VE(PASS1$T0P - PASS1$LEN , .DEBUGGING, PASSliLEN ) J 
LIST$END = .LIST$BUFF + 12?; 

LIST$PTR = .LIST$BUFF + LIST$PTRJ 
OUTPUT$END = .OUTPUT$BUFF + 127J 
OUTPUT$PTR = ,OUTPUT$BUFF + OUTPUT$PTR? 

CALL PRI NT$ERROR ( FALSE ) J /* INITIALIZE ERROR MSG OUTPUT */ 

/if if if if # if if PARSER # # # # * #/ 

DO WHILE COMPILING; 

IF STATE <= MAXRNO THEN /* READ STATE */ 

do; 

CALL INCSP ? 

STATES TACK ( SP ) = STATE 5 /* SAVE CURRENT STATE */ 

CALL look/head; 

I = GETINIJ 
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J = I + GETIN2 - l; 

DO I = I TO j; 

IF READl(I) = TOKEN TEEN 

do; 

IF (TOKEN = I NPUT $S TR ) OP. 

(TOKEN = LITERAL) THEN 
DO K = 0 TO ACCUM ( 0 ) ? 

VARC(K) = AC CUM ( K ) J 

end; 

STATE = READ2 ( I ) J 
NOLOOK = true; 
i = j; 

end; 

ELSE IF I = J THEN 

do; 

CALL PRINT$ERR0R( 'NP' ) ,* 

CALL PRI NT ( . ( ' ERROR NEAR $')); 

CALL print$accum; 

IF (STATE := RECOVER) = 0 TEFN 
COMPILING = FALSE; 

END; /* END OF IF I = J */ 

END; /* END OF I = I TO J */ 

PMT) : / ¥ TTNiD nv P1TAD ^ T A T P / 

ELSE IF STATE > MAIPNO TEEN /* APPLY PRODUCTION STATS */ 

do; 

MP = SP - GETIN2 J 
mppi = MP + i; 

CALL CODE$GEN (STATE - MAXPNO); 

SP = mp; 

I = GETIN1 ; 

J = STATESTACK(SP) ; 

DO WHILE (K := APPLYl(I)) <> 3 AND J <> K; 

I = I + i; 

END ; 

IF (K := APPLY2( I ) ) = 0 THEN COMPILING = FALSE; 
STATE = KJ 

end; 

ELSE IF STATE <= MAXLNO THEN /^LOOKAHEAD STATE 5 "/ 

do; 

I = GETINl ; 

CALL lookahead; 

DO WHILE (K := LOOKl(I)) <> 0 AND TOKEN <> K; 

I = I +15 

end; 

STATE = L00K2(I); 

END; 

ELSE do; /*PUSH STATES 5 "/ 

CALL INCSP ? 

STATESTACK(SP) = GETIN2; 

STATE = GET I N 1 J 

end; 
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END? /* OF WHILE COMPILING */ 

CALL CODE$BYTE(TER); 

CALL ADDR^OUT (MAX$ INT $MEM ) J 
IF NOT NO$CODE THEN 

do; 

CALL WRITE$OUTPUT ( .OUTPUTS BUFF , . OUTPUT SFCB) 5 
CALL CLOSE( .OUTPUT<FCB) ; 

end; 

call checksunresolved; 
call crlf; 
call dcrlf; 

DO I = 0 TO 4 ; 

CALL PRINT$CEAR(ERROR$CTR( I ) ) ; 

CALL WRITE$TO$DISK ( ERROR $CTR( I ) ) ; 

end; 

CALL PRINT (.(' PROGRAM ERROR( S )$')); 

DO WHILE LIST$PTR < LIST$END> 

CALL WRITE$TO$DISK ( ' '); 

end; 

CALL WRITE$TO$DIS£( ' '); 

CALL CLOSE ( .LIST$FC3) ; 

CALL boot; 
end; 
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COMPUTER LISTING FOR MODULE CINTERP NPS MICRO-COBOL 



$ TITLE ( 'NPS MIRCO-COBOL COMPILER INTERP ' ) PAGEWI DTF ( 80 ) 
PACELENGTH(60 ) 

INTERP: DO? 



/* 



*/ 



COBOL COMPILER-INTERPRETER 
/* NORMALLY LOCATED AT 103H */ 

/* GLOBAL DECLARATIONS AND LITERALS */ 



DECLARE 



DCL 



DCL 



DCL 


LITERALLY 


'DECLARE ', 


LIT 


LITERALLY 


'LITERALLY' 


CR 


LIT 


'13', 


EA LSE 


LIT 


'0', 


FOREVER 


LIT 


'WHILE TRUE 


LE 


LIT 


'10', 


PROC 


LIT 


'PROCEDURE' 


SER 


LIT 


'12', /* 


TAB 


LIT 


'09H ' , 


TRUE 


LIT 


'1', 


ZONE 


LIT 


'60H'; 



/* UTILITY VARIABLES */ 



A$CTR 


ADDRESS , 






• 




BASE 


ADDRESS , 










BOOTER 


ADDRESS 






INITIAL 


(00 


3$ADDR 


BASED BASE 


(1) 




ADDRESS, 




B$BYTE 


BASED EASE 


(1) 




BYTE, 




CALL$BASE 


ADDRESS , 










CALL^PTR 


BASED CALL$BASE 


(1) 


ADDRESS, 




CALL$TOP 


ADDRESS , 










CTR 


BYTE, 










CTR1 


BYTE, 










ERR0R$CTR(5 ) 


BYTE 






INITIAL 


(' 


HOLD 


ADDRESS , 










E^ADDR 


BASED HOLD 


(1) 




ADDRESS, 




H$BYTE 


BASED HOLD 


(1) 




BYTE, 




HI $ FREE $ MEM 


ADDRESS , 










LOW$EREE$MEM 


ADDRESS , 










EI$OFESET 


ADDRESS 






INITIAL 


(0) 


LOW$OEESET 


ADDRESS 






INITIAL 
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CODE$START ADDRESS I N ITI AL ( 3500H ) , 

PR OGRAM$ COUNTER ADDRESS, 

C$ADDR BASED PROGRAM$COUNTER ( 1 ) ADDRESS, 

C$ BYTE BASED PROGRAM$ COUNTER ( 1 ) BYTE, 

MAX$MEMORY ADDRESS IN I TI AL ( 0B1 00H ) ? 

/***** GLOBAL INPUT AND OUTPUT ROUTINES * * * * */ 

DCL 

CURRENT$FCB ADDRESS, 

START$OFFSET LIT '37'; 

MONl: PROC ( F ,A ) EXTERNAL? 

DCL F BYTE, A ADDRESS? 

END MON1J 

MON 2: PROC (F,A) BYTE EXTERNAL? 

DCL F BYTE, A ADDRESS? 

END MON2? 

PR INT$CHAR : PROC (CHAR)? 

DCL CHAR BYTE? 

CALL MONl (2, CHAR)? 

END PRINT$CHAR? 

CRLF : PROC? 

CALL PRINTSCEAR(CR) J 
CALL PRINT$CEAR(LF); 

END CRLF? 

PRINT: PROC (A); 

DCL A address; 

CALL CRLF? 

CALL MONl (9 , A) J 
END print; 

READ: PROC (A); 

DCL A ADDRESS? 

CALL MON1(10,A); 

END READ? 

PRINT$ERROR : PROC (CODE)? 

DCL CODE ADDRESS, I BYTE, TEN LIT '39E'? 

CALL CRLF? 

CALL PR I NTSC EAR (HIGH( CODE) ) ? 

CALL PRI NTSCFAR ( LOW ( CODE ) ) ? 

I = 4? 

DO VEILS (ERROR$CTR ( I ) := ERRORSCTR ( I ) + 1) = TEN? 
ERROR$CTR( I ) = '0'; 

IF I > 0 THEN 
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IT ERROP$CTR(I := I - 1) = ' ' THEN 
ERROR$CTR( I ) = '0"; 

end; 

END print$error; 

FATAL$ERROR: PROC(CODE); 

DCL CODE address; 

CALL print$error(code); 

CALL M0N1(9,.(' FATAL ERROR $ ' ) ) ; 

CALL booter; 

END fatal$error; 

SET$DMA : PROCJ 

CALL MON1 (26, CURRENT $FCB + START $OFFSET ) ; 

END set$dma; 

OPEN: PROC ( ADDR ) BYTE? 

DCL ADDR ADDRESS, RET BYTE? 

CALL MON 1 (26,80H); 

RET = M0N2 ( 1 5 , ADDR ) J 

CALL SET$DMA; /* RESET BUFFER V 

RETURN RET; 

END open; 

CLOSE: PROC (ADDR); 

DCL ADDR ADDRESS? 

CALL MON1 ( 26 ,80H ) ? 

IF M0N2 ( 1 6 , ADDR ) = 255 THEN CALL FA TAL^ERROR ( 'CL ' ) 5 
CALL SET$DMA; /* RESET BUFFER */ 

END close; 

DELETE: PROCJ 

CALL MON1 (19,CURRENT$FCB) J 

end delete; 

MAKE: PROC (ADDR)J 

DCL ADDR ADDRESS? 

IF M0N2 ( 22 , ADDR ) = 255 THEN CALL FA TAL$ ERROR ( 'ME ' ) J 
END make; 

DISK$READ : PROC BYTE; 

RETURN MON2(20,CURRENT$FC3); 

end diskSread; 

DISK$WRI TE : PROC BYTE; 

RETURN MON 2 ( 21 , CURRENT$FCB ) J 

END disk$write; 

/*******### UTILITY PROCEDURES ##*##**###/ 



DCL 
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SUBSCRIPT 



(8) 



ADDRESS ,* 



RES: PROC(ADDR) ADDRESS » 

/* THIS PROC RESOLVES TEE ADDRESS OF A SUBSCRIPTED 
IDENTIFIER OR A LITERAL CONSTANT */ 

DCL ADDR ADDRESS, 

I bite; 

IF ADDR > 32 THEN 

IF ADDR > HI$FREE$MEM THEN RETURN ADDR - HI $OFFSET 
ELSE RETURN ADDR + LOVSOFFSET; 

IF ADDR < S THEN RETURN SUBS CRIPT ( ADDR ) J 
IF ADDR > 12 TEEN RETURN CALL$PTR (ADDR - 12); 

DO CASE ADDR - 10; 

RETURN .(' '); 

RETURN . (2?H); 

RETURN .('0'); 

end; 

RETURN 0J 
END res; 

MOVE : PROC (FROM, DESTINATION .COUNT) ; 

DCL (FROM, DESTINATION, COUNT) ADDRFSS, 

(F BASED FROM, D BASED DESTINATION) BITE; 

DO WHILE (COUNT := COUNT - 1 ) <> 0FFFFE; 

D = f; 

FROM = FROM + 1? 

DESTINATION = DESTINATION + i; 

end; 
end move; 

FILL: PROC (DEST I NATION .COUNT, CHAR) ; 

DCL (DESTINATION, COUNT) ADDRESS, 

( CHAR ,D BASED DESTINATION) BITE; 

DO WHILE (COUNT := COUNT -1)0 0FFFFHJ 
D = char; 

DESTINATION = DESTINATION + l; 

end; 

END fill; 

FILLER: PROC BITE; 

IF C$ADDR ( 1 ) = 03H THEN RETURN 2?H; 

ELSE IF C $ADDR ( 1 ) = 0CE THFN RETURN '0'J 
ELSE RETURN ' '; 

END filler; 

CONVERT $TO$HEX : PROC (POINTER .COUNT ) ADDRESS; 

DCL POINTER ADDRESS, ( COUNT , CHAR , CTR ) EITE; 

A$CTR = 0; 

BASE = pointer; 

DO CTR = 0 TO COUNT - l; 

IF ((CEAR := B$BITE( CTR ) ) = '-') OR 
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( (C W AR - ZONE >= '0' ) AND 
(CHAR - ZONE <= '9')) THEN RETURN A$CTR := 0? 

IF CHAR = ' . ' THEN RETURN A$CTR? 

IF CHAR <> '+' THEN 

A$CTR = SEL ( A$CTR, 3 ) + SEL(A$CTR.l) + 

(CHAP - '0')? 

end; 

RETURN A$CTRJ 
END CON VERT $TO$EEX> 

/** * * ****** CODE CONTROL PROCEDURES *********/ 

DCL BRAN CH$FLAG BYTE I N I TI AL ( FALSE) ; 

INC$PTR: PROC (COUNT); 

DCL COUNT BYTE? 

PROGPAM$COUNTER = P ROG RAM $ COUNTER + COUNT? 

END inc$ptr; 

GET$OP$CODE : PROC BYTE; 

CTR = C$BYTE (0 ) ; 

CALL INC$PTR(1); 

RETURN CTR? 

end get$op$code; 

COND$BRANCH: PROC (COUNT); 

/* THIS PROC CONTROLS BRANCHING INSTRUCTIONS */ 

DCL COUNT BYTE? 

IF BRANCH$FLAG THEN 

do; 

BRANCH$FLAG = FALSE? 

PRO GRAM £ COUNTER = C $ADDR (COUNT ) ? 

end; 

ELSE CALL I NC$PTR ( SEL ( COUNT , 1 ) + 2); 

END cond^branch; 

INCR$OR£BRANCE: PROC ( MARK ) ? 

DCL MARK BYTE? 

IF MARE THEN CALL INC$PTR(2); 

ELSE PROGRAM$COUNTER = C$ADDR(0); 

END incr$op.$branch; 

COMPARISONS ’S'##**#*'###*'##/ 



CHAR$COMPARE : PROC BYTE? 

DCL A $ AD DR ADDRESS? 

A$ADDR = FILLER? 

IF C $ADDR (1 ) > 09H AND C$ADDR(1) < 0DH THEN 
DO A$CTR = 0 TO C $ADDR ( 2 ) - 1? 

IF B$BYTE(A$CTR) > AiADDR THEN RETURN 1? 
IF B$BYTE ( A$CTR ) < A$ADDR THEN RETURN 0? 
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end; 

ELS^ 

~D0 A $ C T R = 0 TO C$ADDR(2) - 1? 

IE B$BYTE(A$CTR) > HSBYTE (A$CTR ) THEN RETURN 1 
IF B$BYTE(A$CTR) < H^BYTE (A^CTR ) THEN RETURN 0 

end; 

RETURN 2’, 

END CHARiCOMPAREJ 

NUMERIC : PROC(CEAR) BYTE; 

DCL CHAR BYTF; 

RETURN (CHAR >= '0') AND (CHAR <= '9'); 

END numeric; 

LETTER: PROC(CHAR) BYTE; 

DCL CHAR BYTE; 

RETURN (CHAR >= 'A') AND (CHAR <= 'Z')J 

END letter; 

SIGN: PROC ( CHAP ) BYTE; 

DCL CHAR BYTE; 

RETURN (CHAR = '+') OR (CHAR = 

END sign; 

CHK$S $NUM : PROC(BASE) BYTE; 

DCL BASE ADDRESS, 

B$BYTE BASED BASE (1) BYTE, 

(I, LENGTH) BYTE; 

DO I = 1 TO (LENGTH := C$ADDR(2) — 1 ) — 1 5 

IE NOT NUMERIC (B$BYTE( I ) ) THEN RETURN FALSE; 

end; 

IE NUMER I C ( B $BYTE (0 ) ) AND NUMERIC (B$BYTS( LENGTH ) ) THEN 
RETURN FALSE; 

CALL MOVE(BASE, .R0, LENGTH + 1); 

IF NUMEPIC(B$BYTE(0) - ZONE) AND 
NUMERIC (B$EYTF(LENGTE) ) THEN 
R0(0 ) = R0 (0 ) - zone; 

ELSE IE NUM.ERIC(B$BYTE(0)) AND 

NUMERIC (B$BYTE(LENGTH) - ZONE) THEN 
R0(LENGTH) = R0( LENGTH ) - ZONE ; 

ELSE RETURN FALSE? 

RETURN TRUE? 

END cek$s$num; 

STRING$COMPARE: PROC(PIVOT); 

DCL PIVOT byte; 

HOLD = RES(C$ADDR(1)) ; 

IE CHE$S$NUM (BASE := RES ( C$ADDR( 0 ) ) ) THEN BASE = .50? 
ELSE IF CHE$S$NUM (HOLD) THEN HOLD = .R0J 
IF CHAR$COMPARE = PIVOT TEEN 

BRANCH$FLAG = NOT BRANCH$FLAG ; 
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CALL C0ND$BRANCE(3); 

end string$compare; 

COMP$NUM$l T NS IGNED: PROC? 

BASE = RES(CSADDRO)); 

DO A$CTR = 0 TO CUDDR(l) - 1? 

IF NOT NUMFR I C ( B$BYTE( A$CTP ) ) TEEN 
A$CTR = C$ADDR(1) + 1J 

end; 

IF A$CTR = C $ADDR ( 1 ) TEEN BRANCH$FLAG = NOT BRAN CH$FLAG > 
CALL C0ND$BRANCH(2) 5 
END C OMP£NUM$ UN S IGNED; 



COMP$NUM$SIGN : PROC; 

DCL (CHAR ,SIGN$FLAG) BYTE; 

SIGNSFLAC- = FALSE; 

BASE = RES(C$ADDR(0)) ; 

DO A$CTR = 0 TO CiADDR(l) - 15 

IF NOT NUMER I C ( CHAR := E$ P YTE ( A $CTR ) ) TEEN 

IF (A$CTR = 0) OR ( A$CTR = C$ADDP.(1) - 1) THEN 
IF (SIGN(CSAR) OR NUMERIC (CHAR-ZONE ) ) AND 
NOT SIGN $FLAG THEN 
S IGN $FLAG = TRUE; 

ELSE A £CTR = C$ADDR(l) + 1J 
ELSE A$CTR = C$ADDR(1) + 1; 

end; 

IE A$CTR = C $ADDP ( 1 ) THEN BRANCH$FLAG = NOT BPANCH^FLAG; 
CALL C0ND$BRANCH(2); 

END COMP$NUM$SIGN5 



COMPiALPHA: PROC? 

BASE = RES ( C $ADBR ( 0 ) ) 5 
DO A$CTR = 0 TO C $ADDR ( 1 ) - 1J 

IF NOT LETTER (B$BYTE(A$CTR)) THEN 
A$CTR = C$ADDR(1) + l; 

end; 

IF AiCTR = C^ADDP(l) THEN BRANCHSFLAG = NOT BRAN CHiFLAG J 
CALL C0ND$BRANCE(2); 

end comp$alpha; 



/Jts ^NUMERIC operations * «***«****#/ 



DCL (R0 f Rl,R2) (18) 
DEC$PT0 BYTE, 
DEC^PTl BYTE, 
DEC$PT2 BYTE, 
DEC$PTA(?) BYTE 
MOVE$FLAG BYTE 
OVERFLOW BYTE, 
R$ PTR BYTE, 

REG$LENGTH BYTE 



BYTE, /* REGISTERS */ 

AT ( .DEC $PT0 ) , 
INITIAL(FALSE) , 

INI TIAL ( 10 ) , 
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S IGN0 (3 ) BYTE, 
SWITCH BITE, 

TEMP BYTE, 

NEGITIVE LIT 
POSITIVE LIT 




CHECKSFORSSIGNj PROC(CEAR) BYTE ? 

DCL CHAR BYTE; 

I? NUMFPIC(CHAR) THEN RETURN POSITIVE; 

IF NUMERIC (CHAR - ZONE) THEN RETURN NEC-IT I VE5 
CALL PRINTS ERROR ( 'S I ' ) ; 

RETURN POSITIVE; 

end check$for$sign; 

STORES IMMEDIATE : PROC5 
DO CTR = 0 TO 9; 

R0(CTR ) = R2 (CTR ) ; 

end; 

DECS PT0 = DECSPT?; 

S I GN0 ( 3 ) = SIGN0(2); 

END storesimmediate; 

ONFSLEFT: PROC? 

DC L CTB B YTE J 

IF SHL(B$BYTE(0) ,4) = 0 OR MOVESFLAG THEN 

do; 

DO CTR = 0 TO REGSLENGTH - 2; 

BSBYTE ( CTR ) = SHL ( BSBYTE (C TR ) , 4) OR 

SHR (B$BYTE (CTR + l),4); 

end; 

bsbyte(regslengte - 1) = 

SHL(B$BYTE(PEGSLENGTH - 1),4); 

end; 

ELSE OVERFLOW = TRUE; 

END ONESLEFT; 

ONESRIGHT: proc; 

DCL CTR BYTE; 

CTR = REGSLENGTH; 

DO INDEX = 1 TO REGSLENGTH - i; 

CTR = CTR - l; 

BSBYTE(CTR) = SHR ( B$3YTE( CTR ) , 4 ) OR 

SHL ( BSBYTE ( C TR - l),4); 

end; 

B$BYTE ( 0 ) = SER(BSBYTE(0) ,4) J 
IF BSBYTE (0) = 09H TEEN 
B$BYTE(0) = 99E; 

end onesriget; 

SHIFTSrIGHT: proc(count); 

DCL COUNT EYTE; 
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ro ctr = i to count; 
call one$right; 

end; 

end seift$riget; 

SBIFT$LEET : PROC (COUNT); 

DCL COUNT BITE; 

OVERFLOW = FALSE? 

IF COUNT = 0 THEN 

do; 

CTR = 0J 
RETURN ; 

end; 

DO CTR = 0 TO COUNT - l; 

CALL one$left; 

IF OVERFLOW AND NOT MOVE$FLAG THEN RETURN; 

end; 

end shift$left; 

ALLIGN: PROC; 

DCL (X ,Y ) eyte; 

RIGHT$OP : PROC ( ADDR ) ; 

DCL ADDR ADDRESS? 

IF OVERFLOW THEN 

do; 

base = addr; 

CALL SHIFT$RIGET( Y := X - CTR); 

OVERFLOW = FALSE? 

end; 

END RIGHT$OPJ 
Y = 0; 

IF DEC $PT0>DEC $PT1 TEEN 

do; 

BASE = .Ri; 

CALL SHIFT$LEFT(X := DFC$PT0 - DEC$PTl); 
DEC $PT1 = DSC$PT1 + CTR; 

CALL R IGHT$OP ( .R0) ; 

DEC $PT0 = DEC$PT2 - Y; 

end; 

ELSE 

do; 

BAS E = R0 # 

CALL SHIFT$LEFT (X := DEC^PTl - DEC$PT0); 
DEC $PT0 = DEC$PT0+CTR; 

CALL HIGHT$0P(.R1); 

DEC $PT1 = DEC $PT1 - Y? 

end; 

END ALLIGN ; 

ADD$TO$END: PROC(CY); 
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DCL ( CY , I ,J) byte; 

CTR = REG$LENGTE - 15 

DO J = 1 TO regslength; 

I = B$BYTE (CTR ) j 
I = DEC(I+CY); 

CY = CARRY AND 1? 

BiBYTE(CTR) = 15 
CTR = CTR - l; 

end; 

end add$to$end; 

ADD$R0 : PROC(SECOND, DEST); 

DCL (SECOND, DEST) ADDRESS, (CY,A,B,I,J) BYTE; 

HOLD = second; 

BASE = lest; 
cy = 0 ; 

CTR = REG$LENGTE - 1J 

DO J = 1 TO reg$lenc-th; 

A = R0(CTR)5 
B = Hi BYTE (CTR) 5 
I = DEC ( A+CY ) J 

CY = carry; 

I = DEC (I + 3); 

CY = (CY OR CARRY) AND 15 
3$BYTE ( CTR ) = i; 

CTR = CTR - i; 

end; 

IE CY THEN CALL ADD$TO?END( CY) ; 

END ADD$R0 5 

COMPLIMENT: PROC(NUMB); 

DCL NUMB BYTE; 

SIGN0( NUMB ) = S IGN0 ( NUMB ) XOR 1? /* COMPLIMENT SIGN */ 

DO CASE NUMB; 

HOLD = .R0J 
HOLD = .Ri; 

HOLD = .R2; 

end; 

DO CTR = 0 TO REC-iLENGTE - l; 

E$BYTE ( CTR ) = 99H - EiBYTE ( CTR ) J 

end; 

END compliment; 

R2$ZER0: PROC BYTE? 

DCL I byte; 

IE (SHL(R2(0),4) <> 0) OR ( SFR (R2 ( 9 ) , 4 ) <> 0) 

THEN RETURN FALSE; 

ELSE DO I = 1 TO 8? 

IF R2(I) <> 0 TEEN RETURN FALSE? 

end; 

RETURN TRUE? 
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END R2SZEP0; 

LEA DINGS ZEROES: PROC(ADDR) BYTE; 

DCL COUNT BYTE, ADDR ADDRESS; 

COUNT = 0; 

BASE = apdr; 

DO CTR = 0 TO 9; 

IF (B$BYTE ( CTR ) AND 0F3E) <> 0 THEN RETURN COUNT; 
COUNT = COUNT + 1? 

IE ( B$3YTE( CTR ) AND 0EE ) <> 0 THEN RETURN COUNT; 
COUNT = COUNT + 1J 

end; 

RETURN COUNT; 

END LEAD I NG$ ZEROES J 

CEECKSRESULT: PROC; 

IF S HR ( R 2 ( 0 ) , 4 ) = 9 TEEN CALL COMPLIMEN T( 2 ) ; 

BASE = .R2J 

CALL ADD$TO$END(05E); 

IF (SHR(R2(0 ) ,4)00) AND ( DECSPT2 = 0) THEN 
OVERFLOW = TRUE? 

ELSE 

IF ( SHR ( R2 (0 ) , 4) <> 0) THEN 

do; 

CALL SHIFT$RIGHT(1 ); 

DECSPT2 = DECSPT2 - 1? 

END ; 

B$BYTE (9 ) = B$BYTE(9) AND 0F0H? 

IF LEADING^ ZEROES ( .R2) > 19 THEN 
S IGN0 (2 ) = positive; 

END checksresult; 

CHECKSSIGN: PROC; 

S IGN0( 2 ) = positive; 

IF SIGN0(0) AND SIGN0(1) THEN RETURN; 

IF (NOT S IGN0 ( 0 ) ) AND (NOT SIGN0(1)) THEN 

do; 

S IGN0 (2 ) = negitive; 

RETURN J 

end; 

IF S IGN0 ( 0 ) THEN CALL COMPLIMENT ( 1 ) ; 

ELSE CALL COM.PLIMENT(0) ; 

END check$sign; 

CHECKSNUMERIC: PROC; 

DCL I byte; 

BASE = .R3J 
DO I = 0 TO 27; 

IF NOT NUMERIC (SER( B$ BYTE ( I ) ,4) OR '0') OR 

NOT NUMERIC ( (B$BYTE ( I ) AND 0FH) OR '0') THEN 
CALL PRINT$ERROR( 'NE') J 
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end; 

END CEECK$NUKERICJ 

CEECKSDEC I MAL : PROCJ 

IE DEC$PT2<> ( CTR := C$BYTE(3)) THEN 

do; 

MOVE$FLAG = TRUE; 

BASE = .R2J 

IF DECSPT2 > CTR THEN CALL 

shift Bright (dfc$pt2 - ctr); 

ELSE CALL SHIFT$LEFT ( CTR-DEC $PT2 ) ? 

M.OVE$FLAG = FALSE J 

end; 

IF LEADINGS ZEROES ( .R2) < 19 - C$EYTE(2) THEN' 

OVERFLOW = TRUE? 

END check^decimal; 

ADD: PROC; 

CALL CHECK$NUMERIC; 

OVERFLOW = FALSE? 

CALL allign; 
call check$sign; 

DEC$PT2 = DEC$PT0J 
CALL ADDR0( ,R1 f ,R2); 

call check$result; 
end add; 

ADD$SERIES : PROC (COUNT); 

DCL (I .COUNT) BYTE? 

DO I = 1 to count; 

CALL ADD$R0 ( .R2, ,R2); 

end; 

END ADD$SERIES; 

SET$^ULT$DIV : PROC; 

CALL CHECK$NUMERIC; 

OVERFLOW = FALSE? 

REG $ LENGTH = 165 

SIGN0( 2) = (NOT ( S IGN 0 ( 0 ) XOR SION0(1))) AND 01HJ 
CALL FILL ( ,R2 ,18,0 ) » 

END SET$MULT$DIV; 

R1$GREATEP: PROC BYTE? 

DCL I byte; 

DO CTR = 0 TO 95 

IF R1(CTR)>( I := 99H - R0(CTR)) THEN RETURN TRUE 
IF R1(CTR)<I THEN RETURN FALSE J 

END ? 

RETURN TRUE? 

end ri$greater; 
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MULTIPLY: PROC(VALUE); 

I) CL VALUE BYTE* 

IF VALUEO0 TEEN CALL ADD$SERIES ( VALUE ) J 
BASE = .50? 

CALL one$left; 
end multiply; 

DIVIDE: PROC; 

DCL (I, J, K, x) byte; 

IF LEADINGS ZEROES ( . R0 ) > 19 THEN 

do; 

OVERFLOW = true; 

RETURN J 

end; 

IF LEADINGS ZEROES (. R1 ) > 19 TEEN 

do; 

CALL FILL( ,R2, 18,0) 5 

return; 

end; 

CALL SET$MULT$DIV; 

PASE = .R0J 

CALL SEIFT$LEFT(17); 

DEC$PT0 = DEC$PT0 + CTRJ 
BASE = .Ri; 

CALL SHIFTS LEFT (IV); 

DEC $PT1 = DECSPT1 + CTR; 

OVERFLOW = FALSE*, 

IF DECSPT0 > 17 THEN 

IF DECSPT1 < (X := DEC$PT0 - 17) THEN 

do; 

OVERFLOW = TRUE; 

DECSPT2 = 0? 

end; 

ELSE 

DECSPT2 = DEC $PT1 - XJ 

ELSE 

DECSPT2 = DECSPT1 + (17 - TECSPT0); 
CALL COMPLIMENT(0); 

DO I = 1 TO 19; 

j = 0; 

DO WHILE risgreater; 

CALL ADD$R0 ( .R 1 , .Rl) ; 

IF Rl (0 ) = 99H THEN 

CALL COMPLIMENT (l); 

J = J + i; 

end; 

K = SHR(I.l); 

IF I THEN R2(K) = R2(K) OR JJ 
ELSE R2(K) = R2(K ) OR SHL(J,4); 

BASE = .R0; 

call onesright; 
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end; 

REG$LENC-TH = 10? 

CALL check$result; 

END divide; 

LOAD$A$CHAR: PROC(CHAR); 

DCL CHAP BYTE,* 

IF (SWITCH := NOT SWITCH) THFN 

B$BYTE(R$PTF) = B$BYTE ( R$?TR ) OR SEL ( CHAR - 30H.4); 
ELSE B$3YTE ( R$PTR := R$PTR-1) = CHAR - 30E; 

end load$a$char; 

LOAD$NUMBERS : PROC (ADDR, CN T) J 

DCL ADDP ADDRESS, (I,CNT)BYTE; 

HOLD = RES (ADDR); 

CTR = cnt; 

DO INDEX = 1 TO CNT; 

CTR = CTR - i; 

CALL LOAD$A$CHAR(E$BYTE(CTR) ) ; 

end; 

CALL INC$PTR(5); 

END LOAD$NUMBERS J 

SET$LOAD: PROC (SIGM$IM); 

DCL ( C TR ,S IGN$ IN ) BYTE; 

DO CASE (CTR := C$BYTE(4)); 

BASE = .R0; 

BASF = .Ri; 

BASE = ,R2; 

end; 

DEC$PTA (CTR ) = C$BYTE(3); 

SIGN0( CTR ) = SIGN$IN; 

CALL FILL (BASE, 18, 0) ; 

R$PTR = 9; 

SWITCH = false; 

END set$load; 

LOAD$NUMER IC : PROCJ 
CALL set$loae(i); 

CALL LOAD$ NUMBERS (RES ( C$ADDR ( 0 ) ) ,C$BYTE(2) ); 

END LOADiNUMERIC ; 

LOAD$NUM$L IT : PROC; 

DCL(LIT$SIZE ,FLAG ) BYTE? 

CHARSSIGN: PROCJ 

LI T$S IZE = LITSSIZE - 1J 
HOLD = HOLD + 1J 

END char$sign; 

LIT$S I ZE = C$BYTE(2)J 
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HOLD = RES ( C $ ADDR ( 0 ) ) J 
IF H$3YTE(0) = THEN 
do; 

CALL char$sign; 

CALL SET$LOAD(NEGITIVE ) ; 

end; 

ELSE 

do; 

IF H$EYTE (0 ) = ' + ' THEN CALL CHAR$SIGN; 

CALL SET$LOAD(POSITIVE) ; 

end; 

FLAG = 0; 

CTR = lit$size; 

DO INDEX = 1 TO LIT4SIZE; 

CTR = CTR - l; 

IF E$BYTE(CTR) = THEN FLAG=LIT$S I ZE - (CTR + l); 

ELSE CALL LOAD$A $CHAR ( H$BYTE ( CTR ) ) ; 

end; 

DFC$PTA(C$3YTE(4) ) = FLAG; 

CALL INC$PTR(5)J 

END load$num$lit; 

STORE$ONE : PROC J 

IF(SWITCH := NOT SWITCH) THEN 

B$BYTE ( 0 ) = SHR(H$BYTE ( 0 ) ,4) OR '0'; 

ELSF 

do; 

HOLD = EOLD - l; 

* B$BYTE (0 ) = (H$3YTE( 0 ) AND 0FH ) OR ' 0 '; 

end; 

BASE = EASE - l; 

end store$one; 

STORE^AS^CHAR : PROC (COUNT); 

DCL COUNT BYTE? 

switch = false; 

HOLD = . R2 + 9J 

IF C$BYTE(4) <> SER OR NOT OVERFLOW THEN 
DO CTR = 1 TO COUNT; 

call store$one; 

end; 

end store$as$char; 

SET$ZONE : PROC (ADDR)J 
DCL A DDR ADDRESS; 

IF NOT SIGN0(2 ) THEN 

do; 

BASE = addr; 

IF C$BYTE(4) <> SER OR NOT OVERFLOW THEN 
B$BYTE(0) = BiBYTE ( 0 ) + ZONE; 

end; 
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CALL INC$PTR(4)J 

end setszone; 

SET$SIGN$SEP: PROC (ADDR ) ; 

DCL ADD? ADDRESS; 

BASE = ADDR J 

IF C $EYTE (4 ) <> SER OR NOT OVERFLOW THEN 
IF S IGN0 (2 ) THEN B$BYTE ( 0 ) = ' + 

ELSE B$BYTE(0) = 

CALL INC$PTR(4); 

END SET$SIGN$SEP; 

STORESNUMERIC : PROC J 
CALL checksdfcimal; 

BASE = RES ( C $ADDR ( 0 ) ) + C$BYTE(2) - i; 
CALL ST0RE$AS$CHAR(CSBYTE(2) ) J 
END STORE$ NUMERIC * 

MCVE$NUM$EDITED: PROC » 



DCL CHAR BYTE, 

COUNT BYTE, 

FLAG ( 2 ) BYTE, 

FLOAT$VALUE BYTE, 

LAST$ LOAD BYTE, 

LENGTH BYTE. 

MAX$LOAD$?T BYTE, 

MIN$LOAD$PT BYTE, 

PS IT$DEC BYTE, 

PS IT$S I GN BYTE, 

S IGN$OUT byte; 



FLOAT$CHECE : PROC(INDEX); 

DCL INDEX BYTE; 

IF FLAG (INDEX) TEEN 

FLOAT$ VALUE = CHAR; 

ELSE 

do; 

FLAG ( INDEX ) = TRUE; 

IF CTR <> MAXSLOAD$PT OR INDEX = 0 THEN 
MIN $LOAD$PT = CTR + 1J 
IF INDEX = 1 THEN 

PSITSSIGN = ctr; 

end; 

end floatscheck; 

FLOATS VALUE , MIN$LOADSPT = 0; 

FLAG (0 ) .FLAG (1 ) = FALSE; 

PSITSDEC = C$3YTE(11); 

PSITSSIGN = C$BYTE(8); 

MAX$LOAD$PT = C$BYTE(8) - l; 

HOLD = RES ( C SADDR ( 0 ) ) » 
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CALL M0VE(PES(C$ADDR(3) ) .HOLD , C$ADDR (4 ) ) ,* 

IF H$BYTE(MAX$LOAD$PT) = 'B' OR 
H$3YTE (MAX$LOAD$PT ) = 'R' THEN 

do; 

MAX$LOAD$PT = MAX$LOAD$PT - 2; 

PSIT$DEC = PS IT$DEC - 2; 

PSIT$S IGN = PSIT$SIGN - 2J 

end; 

DO CTR = 0 TO MAX$LOAD$PT; 

CHAR = H$BYTE(CTR)J 
IF CHAR = '9' THEN 

H$BYTE( CTR ) = 'O'; 

ELSE IF CHAR = '$' THEN 
CALL FLOAT$CHECK(0) ; 

ELSE IF SIGN (CHAR) THEN 
CALL FLOAT$CHECK(l); 

ELSE IF CHAR = 'Z ' THEN 
FL0AT$7ALUE = CHAR J 
ELSE IF CHAR = 'B' THEN 
H$BYTE( CTR ) = ' '; 

IF CTR > MAX$LOAD$PT - PSIT$DEC THEN 
IF CHAR = '/' OR CHAR = ' ' OR 
CHAR = '0' OR CHAR = ',' THEN 
PS IT$DEC = PS I T$DEC - i; 

END; /* DO CTR = 0 TO MAX$LOAD$PT */ 

IF PS IT$S IGN = MAX$LOAD$PT TEEN 

do; 

MAX$LOAD$PT = KAX$LOAD$PT - i; 

PSIT$DEC = PSITSDEC - 1? 

end; 

LENGTH = C$ADDR(2); 

BASE = .R0; 

CALL FILL(BASE,36, '0') J 

CALL MOVE (RES (C$ADDR( 1 ) ) .BASE , LENGTH ) J 

IF SIGN (E$BYTE (0 ) ) THEN /* CHECK FOR LEADING SIGN */ 

do; 

S IGN $OUT = 3$BYTE( 0 ) J 
EASE = BASE + l; 

LENGTH = LENGTH - l; 

end; 

ELSE IF S IGN (B$BYTE ( C$BYTE ( 4 ) - 1)) THEN 

do; 

S IGN $OUT = B$BYTE(C$BYTE (4) - 1); 

LENGTH = LENGTH - l; 

end; 

ELSE IF NOT CHECK$FOR $S IGN ( B$EYTE ( C $BYTE ( 4 ) - 1)) THEN 
DO; /* CHECK FOR TRAILING IMBEDDED SIGN */ 

S IGN $OUT = 

B$BYTE(C$BYTE(4) - 1) = B$BYTE(C£BYTE(4) - 1) 

- zone; 

end; 
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ELSE IE NOT CHECK$FOR$SIGN (B$BYTE(0 ) ) THEN 

DO; /* CHECK EOR LEADING IMBEDDED SIGN */ 

S IGN $OUT = 

B$BYTE(0) = B$BYTE(0) - ZONE; 

end; 

ELSE S IGN $OUT = '+'? 

IE PSIT^DEC <> C $BYTE ( 10 ) THEN 

DO; /* ALIGN DECIMAL POSITIONS */ 

IE PS I T$DEC < C $3YTE( 10 ) TEEN 

LENGTH = LENGTH - (C$BYTE(10) - PSIT$DEC)J 

E LS E 

LENGTH = LENGTH + (PSITSDEC - C$3YTE(10)); 

end; 

CTR = LENGTH - l; 

COUNT, LAST$LOAD = MAX$LOAD$PTJ 
DO INDEX = 1 TO LENGTH? 

DO WHILE ( H$BYTE( COUNT ) = ' ' OR H$BYTE( COUNT ) = '0' 
OR H$BYTE( COUNT ) = '/' OR H$BYTE ( C CUN T ) = 

OR H$BYTE( COUNT ) = ',') AND 
(COUNT <= MAX$LOAD$PT ); 

COUNT = COUNT - 1J 

end; 

IF B$BYTE ( CTR ) <> THEN 

do; 

IE B$BYTE(CTR) <> '0' THEN 

IF (COUNT < MIN$LOAD$PT) OR 
(COUNT = 255) THEN 

index = length; 

ELSE 

do; 

H$BYTE(COUNT ) = BSBYTE(CTR); 
LAST$LOAD = COUNT? 

end; 

COUNT = COUNT - 1? 

end; 

CTR = CTR - i; 

end; 

IF FLOAT$VALUE <> 0 THEN 

do; 

CTR = 0; 

DO WHILE HSBYTE(CTR) <> FLOAT$ VALUE; 

CTR = CTR + 1? 

end; 

DO WHILE (H$BYTE ( CTR ) = OR B$BYTE ( CTR ) = '0' 
OR E$BYTE( CTR ) = ' ' OR H$BYTE( CTR) = '/' 
OR H$BYTE ( CTR ) = ELOA T$ VALUE ) 

AND (CTR <= MAX$LOAD$PT); 

H$BYTE( CTR) = ' ' J 
CTR = CTR + i; 

end; 

IE FLOAT$VALUE <> 'Z' THEN 



2e? 



do; 

H iBTTE ( CTR := CTR - 1) = FLO*T$VALUE; 

IF SI GN ( FLO AT$ VALUE ) THEN 
PSIT$SIGN = CTR ; 

end; 

END? 

DO CTR = 0 TO last$load; 

IF H^BYTE ( CTP ) = 'o' THEN 
E$BYTE (CTR ) = '0'; 

FLSE 

IF HSBYTE ( CTR ) = ', ' AND 

E$BYTE ( CTR - 1) = '*' TEEN 
H$BYTE ( CTR ) = '*'; 

end; 

DO CTR = LAST$LOA D + 1 TO MAX$LOAD$PT; 

IF H$BYTE ( CTR ) = '*' OR H$BYTE(CTR) = '$' OR 
SIGN(H$BYTE(CTR) ) OR H^PYTE(CTR) = 'O' TFFN 
E$BYTE(CTR) = '0'; 

end; 

IF PSmSIGN < C$BYTE(S) TEEN 

IF E$BYTE(PSIT$SIGN ) = ' + ' TEEN 
H$BYTE(PSIT$SIGN) = SIGN$OUT; 

ELSE 

"iF SIGN$OUT = '+' TEEN 

do; 

IF H$BYTE( PS IT$S IGN ) <> '-' TEEN 
H$EYTE(PSIT$SIGN + 1) = ' '5 
E$BYTE(PSIT$SIGN ) = ' 

end; 

CALL INC$PTR(12)J 

END move$num$edited; 

/**###*##*# INPUT-OUTPUT ACTIONS *########>?/ 



BUFF$PTR 


ADDRESS , 






BUFF$BYTE 


BASED 


BUFF$PTR (1) 


BYTE, 


BUFF $ END 


ADDRESS , 






EUFFSLENGTH 


LIT 


'128', 




BUEFSTART 


ADDRESS , 






CHAR 


BYTE, 






CONSEUFF 


ADDRESS 


INITIAL (80H), 




CON$BYTE 


BASED 


CON $BUFF 


BYTE, 


CON$ I N PUT 


ADDRESS 


INITIAL (82H), 




CONTROL$FLAG 


BYTE 


INITIAL (FALSE) 


t 


CURRENT$FLAG 


BYTE, 






EOF$FLAG$ OFFSET 


LIT 


'36', 




EXTENT$OFFSET 


LIT 


'12', 




FCB$ADDR$A 


BASED 


CURREN T$FCB (l) 


ADDRESS . 


FCB$BYTE$A 


BASED 


CURRENT^FCB (l) 


BYTE, 


FLAG$OFFSET 


LIT 


'33', 




HIGH$VALUE 


LIT 


'0FFH', 
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INVALID 


BYTE, 








PAG 


LIT 


'22', /* CODE 


FOR 


PAGE */ 


PTR$OFFSET 


LIT 


'17', 






REC$ NO 


LIT 


'32', 






RE WRITE $F LAC- 


BYTE 


INITIAL(0H) , 






TERMINATOP. 


LIT 


'1AE ' , 






TOP^OF^PAGE 


LIT 


'0CH', 






VAR$END 


LIT 


'CR', 






WTF 


LIT 


'48'; /* CODE 


FOR 


WRITE */ 


ACCEPT: PROC; 











CALL crlf; 

CALL PRINT$CHAR(3FH); 

CALL TILL (CON $ INPUT , C$BYTE ( 2 ) , ' ')? 

CON$EYTE = 1285 
CALL READ (CON $BUFF ) » 

CALL MOVE (CON $ INPUT, RES (C$ADDR(0) ),C$BYTF(2) ) ? 

CALL INC$PTR(3); 

END accept; 

DISPLAY: PROC J 

DCL E $ C N T BYTE? 

BASE = RES ( C$ADDR ( 0 ) ) ; 

IF NOT C iBYTE (3 ) THEN CALL CRLF J 
B$CNT = C$BYTE(2); 

DO CTR = 0 TO B$CNT - 1J 

CALL PRINT$CHAR(B$BYTE(CTR) ) ; 

end; 

' CALL INC$PTR(4); 

END display; 

GET$FILE$TYPE : PROC BYTE? 

BASE = C$ADDR(0); 

RETURN B$BYTE(FLAG$OFFSET) J 

END get$filestype; 

SET$FILE$TYPE: PROC(TYPE); 

DCL TYPE BYTE; 

BASE = C$ADDR(0); 

IF GET$FILE$TYPE <> 0 THEN CALL FATAL$ERROR ( 'OF ' ) ; 

BiBYTE ( FLAG $ OFF SE T ) = TYPE J 

END set$file$type; 

SET$I $0: PROC? 

INVALID = FALSE; 

IF C$ADDR (0 ) = CURRENTSFCB THEN RETURN; 

/* STORE CURRENT POINTERS AND SET INTERNAL WPITF MARE */ 

BASE = current$fce; 

FCB$ADDR$A(PTR$OFFSET) = EUFFSPTR; 
FC3$BYTE$A(FLAG$0FFSET) = CURREN T$FLAG J 
/* LOAD NEW VALUES */ 
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BUFF$END = (BUEFSSTART := (CTJRRENTSFCB := C$ADDR(0)) + 
START$OFFSET) + BUFF$LENGTH; 

CURRENT$ELAG = FCBSBYTESA(FLAG$0FFSET ) j 
BUFFSPTR = FCE$/ TDRSA ( PTR$OFFSET ) J 
END SET$I$05 

OPEN$FILE: PROC(TYPE); 

DCL TYPE BYTE; 

CALL S ET$FI LE$TYPE( TYPE ) J 
CURRENT$FCB = CSADDR(0)J 
FCB$BYTE$A( EXTENT $0FFSET) = 0J 
CTR = OPEN ( CURRENT $FCB ) ; 

DO CASE TYPE - 1? 

/* INPUT #/ 

do; 

IF CTR = 255 THEN CALL FATAL$ERPOR( 'NF' ) ; 

end; 

/* OUTPUT */ 

do; 

call delete; 

CALL MAXE(C$ADDR(0) ) ; 

end; 

; /# CASE 2 NOT USED */ 

/* i-o */ 
do; 

IF CTR = 255 THEN CALL FATA L$ ERR OR ( 'NF ' ) ; 

end; 

end; /* DO CASE TYPE - 1 */ 

FCB$BYTE$A(REC$NO) = 0; /* SET THE RECORD NUMBER IN ECB #/ 
FCB$BYTE$A(EOF$FLAG$OFFSET) = FALSE; /* SET THE EOF OFF */ 
BUFF$END = (BUFESSTART := ( CURRENT$FCB + STARTSOFFSET ) ) + 

euff$length; 

CURP.ENT$FLAG = FCB$3YTE$ A( FL AG $ OFFSET ) ; 

EUFFSPTR ,FCB$ADDR$A (PTRSOFFSET ) = BUFFSSTART - 1J 
CALL INC$PTR(2); 

END open$file; 

WRI TE$MARK : PROC BYTE? 

RETURN ROL( CURREN TSFLAG , 1 ) ; 

END writesmark; 

SET$VRITE$KARK: PROC; 

CURRENT$FLAG = CURREN T$FLAG OR 80H; 

END set$write$mark; 

VRITESRECORD: PROC 5 
CALL setsdma; 

CURREN T$ FLAG = CURRENT5FLAG AND 0FH; 

IF (CTR := DISK$¥RITE) = 0 THEN RETURN; 

CALL PRINTS ERROR ( 'W8' ) J 
INVALID = TRUE? 
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END write$record; 

READ$RECOF.D : PROC? 

CALL set$dma; 

IE WR ITEiMARE THEN CALL WRITF$ w ECOPD J 
IE (CTR := DISK$P.EAD) = 0 THEN RETURN; 

IF CTR = 1 TEEN FCB$BYTE$A ( EOF$FLAG$ OFFSET ) = TRUE > 
INVALID = TRUE? 

end readsrecord; 

READ$BTTE: PROC BYTE; 

IF (3UFF$PTR := BUFF$PTR + 1 ) >= 3UFFEND THEN 

do; 

call read$record; 

IF FCB$3TTE£A (EOF$FLAG$OFFSET ) TEEN 
RETURN TERMINATOR? 

3UFF$PTR = 3UFF$START; 

end; 

RETURN BUFE$BYTE(0) ; 

END READ$3YTE; 

WRITE$BYTE : PROC (CHAR)J 
BCL CEAR BYTE J 

IF ( BUFF$PTR* J ;= BUFF$PTR+1) >= BUFE$END THEN 

do; 

CALL VtRITESRECORD; 

BUFF$PTR = BUFF$STARTJ 
IF REVRITE$FLAG THEN 

do; 

call read$record; 

FCE£BYTE$A(REC£NO) = ECB ^BYTEiA (REC $NO ) 

end; 

end; 

call set$vrite$mark; 

BUEF$BYTE(0) = CHAR; 

END write$byte; 

WRITE$END$MARK : PROCJ 

CALL WRITE$BYTE(CR); 

CALL WRITE$BYTE(LF) ; 

END WRITESENDSMARKJ 

READ$END$MARK: PROC; 

IF (PEAD$3YTEOCR) OR (READ$BYTE<>LF ) TEEN 
CALL PRINT$ERROR( 'EM') 5 

END rsad$end$mark; 

READ$VARI ABLE :PROC » 

CALL SETiI$0; 

BASE = C$ADDR(2); 

CALL FILL(C$ADDP.(2) ,C$ADDR( 1 ) , ' '); 
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CO A$CTR = 0 TO CiADCR(l) - 1J 

IF (CTR := READSBYTE ) = VAR$END THEN 

co; 

CTR = read$byte; 

RETURN ; 

end; 

IF CTR = TERMINATOR THEN 

do; 

FCB$BYTE$A(E0E$FLAG$0EESET) = TRUE? 

rfturn; 

end; 

B$BYTE(A$CTR ) = CTRJ 

end; 

call read$end$mark; 
end rsad$variable; 

WRITESVARIABLE: proc; 
dcl count address; 

CALL SET$I$0; 

BASE = C$ADDR(1); 

COUNT = C$ADDR(2); 

DO WEILE ( (B$BYTE(COUNT := COUNT - l) = ' ') 

AND (COUNT <> 0) ) ; 

end; 

DO A$CTR = 0 TO COUNT; 

CALL WRITE$BYTE(3$BYTE(A$CTR ) ) ; 

end; 

CALL write$end$mark; 
end write$variable; 

READ $ TO $ MEMORY : PROCJ 
DCL CHAR BYTE; 

BASE = C $ADDR ( 1 ) J 

DO A$CTR = 0 TO C$ADDR(2) - i; 

IE (CHAR := READ$3YTE) = TERMINATOR THEN 

do; 

INVALID, FCB$BYTE$A(E0F$FLA0$0FFSET) = TRUE; 

return; 

end; 

ELSE B$BYTE (A$CTR) = CHAR; 

end; 

CALL read$end$mark; 

END readsto$memory; 

WRI TE$FROM$MEMORY : PROC 5 
BASE = RES ( C $ADDR ( 1 ) ) J 
DO A$CTR = 0 TO C$ADDR(2) - l; 

CALL WRITE$BYTE(B$BYTE(A$CTR) ); 

end; 

IF CON TROL$FLAG THEN 

CALL WRITE$BYTE(CR) J 
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ELSE 

CALL write$end$mark; 
end write$from$memory; 

/#*****«** RANDOM 1-0 PROCEDURES ********/ 



SET$RAN$POINTER : PROC; 

/* THIS PROCEDURE READS TEE RANDOM KEY AND COMPUTES 
WHICH RECORD NEEDS TO RE AVAILABLE IN THE BUFFER 
THAT RECORD IS MADE AVAILABLE AND THE POINTERS 
SET FOR INPUT OR OUTPUT */ 

DCL (BYTE$COUNT, TEMP, RECORD) ADDRESS, 

EXTENT BYTE; 

IF WRITE$MARX THEN CALL WRITE$RECORD? 

TEMP = C0NVERT$T0$HEX(C$ADDP.(3) ,C$BYTE(8) ) J 
IF TEMP = 0 THEN 

do; 

INVALID = TRUE? 



return; 

EN D ? 

BYTE$C OUNT = (C$ADDR(2) + 2) * (TEMP - 1); 
RECORD = SHR(BYTE$C0UNT,7) J 
EXTENT = SHR (RECORD, 7 ) ; 

IF EXTENT <> FCB$BYTE$A(EXTENT$OFFSET) THEN 

do; 

CALL CLOSE (C$ ADDR( 0 ) ) ; 

FCB$BYTE$A( EXTENT$ OFFSET ) = EXTENT; 
IF OPEN (C $ADDR ( 0 ) ) = 255 THEN 

do; 

IF S HR ( CURRENT $FLAG ,1 ) THEN 
CALL MAKE (C$ADDR ( 0 ) ); 

ELSE 

do; 



INVALID = TRUE; 

FCB$EYTE$A(EXTENT$OFFSET ) = 0; 
IF OPEN ( C$ADDR (0 ) ) = 255 THEN 
CALL FATAL$ERROR ( 'OP ' ) > 

end; 

end; 



end; 

BUFF$PTR = (BYTE$COUN T AND 7FH ) + BUFF$START - 1? 
FCB$BYTE$A(32) = LOW(RECORD) AND 7FH J 

CALL read$record; 
end set$ran$pointer; 



GET$RECi NUMBER: PROC ADDRESS? 

DCL (RECORD , LOG I CAL$REC$NUM , BYTE $COUN T ) ADDRESS; 

RECORD = FCB $BYTE$A ( EXTENT $ OFFSET ) J 
RECORD = SHL (RECORD, 7 ) + FCB$ BYTEiA (REC $NO ) ; 

IF NOT SHR( CURREN T$FLAG, 1 ) TEEN RECORD = RECORD - 1? 
BYTE$COUN T = S EL( RECORD ,7 ) + ( (BUFF$PTR + 1 )-BUFF$START ) ? 
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LOGICAL$REC$NUM = (BYTE$COUNT / (C$ADDR(2) +2)) + 1J 
RETURN LOGICAL$RFC$NUM; 

END get$rec*number; 

SET$RELATIVE$KEY : PP.OC; 

DCL (RECTUM, K) ADDRESS, 

(I ,C NT ) BYTE, 

J (4 ) ADDRESS DATA (10000,1000,100,10), 

BUFF (5 ) BYTE? 

rec $num = get*rec$number; 

DO I = 0 TO 3J 
CNT = 0; 

DO WHILE RFC $NUM >= (K := J(I))J 
REC$NUM = REC$NUM - KJ 
CNT = CNT + lj 

end; 

buff(i)=cnt + ' 0 '; 

end; 

BUFF (4) = REC $NUM + '0'; 

IF (I := C$BYTE ( 8) ) <= 5 THEN 

CALL MOVE( . BUFF + 5 - I ,RES(C$ADDR(3) ) ,1 ) ; 

ELSE 

do; 

CALL FILL (RES ( C$ADDR(3 ) ) , I - 5 , '0 ' ) J 
CALL MOVE( .BUFF, RES (C$ADDR(3 ) ) + I - 5,5); 

end; 

end sft$relative$key; 

WRT$EMPTY$REC : PROCJ 

DO A$CTR = 1 TO C$ADDR(2); 

CALL WRITE$BYTE(HIGH$VALUE); 

end; 

CALL write$end$mark; 

END WRT$EMPTY$REC; 

WRITE$DUMMY$RECS : PROC (DIFFERENCE ) J 

DCL DIFFERENCE ADDRESS, COUNT BYTE; 

DO COUNT = 1 TO difference; 

CALL WRT$EMPTY£REC; 

end; 

END WRI TE$ DUMMY $ REC S J 

BACK$ONE$EXTENT : PROCJ 

CALL CLOSE(C$ADDR(0) ) ; 

IF (FC3$BYTE$A( FXTFN T$OFFSET ) : = 

FCB$BYTE$A (EXTFNT^OFFSET ) -1 )=255 THEN 
CALL FATAL$ERROR( 'W?') J 
IF OPEN ( C$ADDR (0 ) ) = 255 THEN 

do; 

CALL FATAL$ERROR ( 'OP'); 

INVALID = TRUE? 
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RETURN ; 

end; 

FC£$BYTE$A(REC$NO) = 127; 

END back$one$extent; 

BACK$ONE£RECORD : PROCJ 

IF( BUFF$PTR := BUFF$PTR - (C$AEDR(2) +2)) >= 
3U?F$START - 1 THEN 

do; 

FCB$BTTE$A(REC$NO) = FCB$BYTE$A(REC$NO) - l; 
RETURN ; 

end; 

BUFF$PTR = BUFF$START - BUFF$PTRJ 
DO WHILE BUFF$PTR > 129; 

BUFF$PTR = BUFF$PTR - 126 ; 

FCB$BYTE$A(REC$NO ) = FCB$BYTE$A (RECSNO) - 1J 

end; 

BUFF$PTR = BUFF$END - BUFF$PTR; 

FCB$BYTE$A(REC$NO ) = FCB$BYTE$A( REC5NO ) - 2,* 

IF FCB$BYTE$A(REC$NO) > 127 TEEN 

do; 

call back$one$extent; 

IF INVALID THEN RETURN; 

CALL read$record; 

FCB$BYTE$A(REC$NO) = 127; 

end; 

ELSE 

do; 

call read$record; 

FCB$BYTE$A (REC$NO) = FCB$3YTE$A (REC $N 0 ) - 1,* 

end; 

end back$one$record; 

REVRITE$SEO: PROC ( FLAG ) J 
DCL FLAG BYTE; 

CALL back$one$record; 

REVRI TE$FLAG = TRUE? 

IF FLAG THEN CALL WRITE$FROM$MEMORY ; 

ELSE CALL WRT$EMPTY$REC J /* THIS IS A DELETE */ 

CALL write$record; 

IF FCB$BYTE$A(REC$NO) = 0 THEN 
CALL back$one$extent; 

ELSE 

FCB$BYTE$A(REC$NO) = FCB$BYTE$A(REC$NO) - l; 
REWRITE$FLAG = FALSE? 

CALL READiRECORDJ 

END rewrite$seq; 

CEECK$DIFFERENCE: PROC? 

DCL (DIFFERENCE, NEXT$RECORD, NEXT^KEY ) ADDRESS; 
NEXT$RECORD = GET$REC$NUMBER; 
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NEXT$KEY = C0NVERT$T0$HEX(C$ADDR(3) ,C$BYTE(S) ) ; 

IF NEXTiRECORD > NEXT$KEY THEN CALL FATAL$ERROR ( 'W2 ' ) * 
DIFFERENCE = NEXT$KEY - NEXT$RECORDJ 

IF DIFFERENCE > 0 THEN CALL WRITE$DUMMY$RECS (DIFFERENCE ) ; 
END check$difference; 

/# #$###$)!(##$$#[* Qf £5 ###$#$#$$#$$#$/ 

LOAD$INC : PROC; 

HSBYTE ( CTR ) = B^BYTE ( CTR1 ) > 

CTR1 = CTR1 + l; 

CTR = CTR + i; 

END LOAD$INC; 

CEECK$EDIT : PROC(CHAR); 

DCL CHAR BYTE; 

IF (CHAR = '0') OR (CHAR = '/') THEN CTR = CTR + 1? 

ELSE IF CHAR = 'R ' THEN 

do; 

H$BYTE (CTR ) = ' '; 

CTR = CTR + l; 

end; 

ELSE IF CHAR = 'A' THEN 

do; 

IF NOT LETTER (3$BYTE( CTRl ) ) THEN 
CALL PRINT$ERROR( ' IC ' ) J 
CALL L0AD$INCJ 

end; 

ELSE IF CHAR = '9' THEN 

do; 

IF NOT NUMERIC (3$3YTE(CTR1 ) ) THEN 
CALL PRINT$ERROR ( ' IC ' ); 

CALL LOAD $ INC; 

end; 

ELSE CALL LOAD$INCJ 
END CHECKSEDIT? 

MACHINE ACTIONS * * * * * * * * * * */ 

STOP: PROC; 

CALL crlf; 

DO CTR = 1 TO 4? 

CALL PRINT$CEAR(ERROR$CTR(CTR) ) ; 

end; 

CALL M0N1(9,.(' EXECUTION ERRORS $ ' ) ) ; 

CALL booter; 

END STOP; 

THE PROCEDURE BELOW CONTROLS THE EXECUTION OF THE CODE. 
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IT DECODES EACE OP-CODE AND PERFORMS TEE ACTIONS 
EXECUTE: PROC 5 

DO forever; 

DO CASE get$op$code; 

; /* CASE ZERO NOT USED */ 

/* 01: ADD */ 

CALL add; 

/* 02: SUB */ 

do; 

S IGN0( 0 ) » S IGN0 ( 0 ) XOR i; 

CALL add; 

end; 

/* 03: MUL */ 

do; 

DCL (I, x) byte; 

CALL SET$MULT$DIVJ 
BASE = .R0; 

CALL SHIFT$RIGET(17); 

BASE = .ri; 

CALL SHIFT$RIGHT(1 ); 

DEC $PT2 = DEC$PT0 + DFC$PT1J 

I = 10; 

DO INDEX = 1 TO 95 

CALL MULTI PLY(R1 ( I := I - 1) AND 0FH ) ; 
CALL MULTIPLY (S HR (Rl ( I ) , 4) ) J 

end; 

BASE = .R2J 

CALL SHIFT$LEFT(17 ) ; 

IF OVERFLOW THEN 

IF (X := CTR + DEC$PT2) < 17 TEEN 
DEC$PT2 = 0; 

ELSE 

do; 

DFC$PT2 = X - 17; 

OVERFLOW = FALSE; 

end; 

REG$LENGTH « 10 J 
CALL check$result; 

end; 

/* 04: DIV */ 

CALL divide; 

/* 05: NEG */ 

BRANCH$FLAG = NOT BRANCE$FLAG; 

/* 06: STP */ 

CALL STOP; 

/* 07: STI */ 

CALL store$immediate; 

/* 03: EXT */ 



297 



IF RTN $3ASE < El $FREE$MEM THEN 

do; 

PROGRAMS COUNTER = RTN $PTR(0) ; 
LOWSOFFSET = RTN$PTH(1)J 
HI$OFFSET = RTN$PTR(2); 

RTNSBASE = RTN$BASE + 6; 

CALL$TOP = call$base; 

CALL$BASE = CALLSPTR(0); 

end; 

/* 09: RND */ 

do; 

IF NOT OVERFLOW TEEN 

do; 

BASE = * R2 J 

IF (DEC$PT2 - C$BYTE ( 0 ) ) > 0 THEN 

do; 

CALL SHIFT$RIGHT (DEC$PT2 
CSBYTE( 0 ) ) J 
DECSPT2 = CS3YTE(0); 

end; 

ELSE 

do; 

CALL SHIFT$LEFT(C$3YTE(0) 
DECPT2) ; 

DEC$PT2 = DEC $PT2 + CTRJ 

end; 

CALL checksresult; 

end; 

CALL INC$PTR(1); 

end; 

/* 10: RET v 

do; 

IF CSADDR( 0) <> 0 TEEN 

do; 

A$CTR = C$ADDR (0 ) ? 

C$ ADDR ( 0 ) = 0; 

PROGRAM$COUNTER = A $ C TR ; 

end; 

ELSE CALL INC$PTR(2); 

END; 

/* 11: CLS */ 

do; 

CALL SETSISO; 

IF WRITE$MARK THEN 

do; 

IF NOT SHR (CURRENTS FLAG ,2) THEN 
CALL WRITF$BYTE (TERMINATOR ) J 

CALL write$record; 

end; 

ELSE CALL SETSDMA; 

CALL CLOSE ( C$ADDR( 0 ) ) ; 
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CURRENT$FLAG,FCB$BYTE$A(FLAG$OFFSET) = 0; 
CALL INC$PTR(2); 

end; 

/* 12: SER */ 

IF OVERFLOW THEN 

do; 

CALL INC$PTR(3); 

OVERFLOW = FALSE? 

end; 

/* 13: BRN */ 

PROGRAM ^COUNTER = C $ADDR ( 0 ) ; 

/* 14: OPN */ 

do; 

CALL OPEN$FILE(l) J 
CALL read$record; 

end; 

/* 15: 0P1 */ 

CALL OPEN $FILE( 2 ) ; 

/* 16: 0P2 */ 

do; 

CALL OPEN $FI LE (4 ) J 

CALL read$record; 

end; 

/* 17: RGT */ 

do; 

IF NOT SIGN0 ( 2 ) THEN 

BRAN CH$FLAG = NOT BRANCE5FLAG ; 

CALL COND$3RANCH(0); 

end; 

/* 18: RLT */ 

do; 

IF SIGN0(2 ) AND NOT R2$ZER0 THEN 
BRAN CH$FLAG = NOT BRANCH$FLAG J 
CALL COND$3RANCH(0 ) J 

end; 

/* 19: REQ */ 

do; 

IF R2$ZER0 THEN 

BRAN CH$FLAG = NOT BRANCH$FLAC-; 

CALL COND$BRANCE(0 ); 

end; 

/* 20: INV */ 

CALL IN CR$OR$BRANCH( INVALID ) ; 

/* 21: EOR */ 

CALL 

INCR$OR $BRAN CH( FCB $3ITE$ A (EOF$ FLAG $ OFFSET ) ) ; 

/* 22: PAG */ 

do; 

DCL I byte; 

CALL SET$I$o; 

IF C$BYTE ( 2) < 100 TEEN 
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DO I = 1 TO C$3YTE(2); 

CALL VRITE$BYTE(LF) J 

end; 

ELSE 

CALL WRlTEiBYTE(TOP$OF$PAGE) J 
IF C$BYTE(3) = WTF THEN 
CON TROL^FLAG = TRUE; 

CALL INC$PTR(3)J 

end; 

/* 23: ACC */ 

CALL accept; 

/* 24: STD */ 

do; 

TEMP = C$EYTE(3); 

C$BYTE(3) = 0; 

CALL display; 

CALL PRINT( . (LF, 'OPERATOR ENTER A <CR> TO 

CONTINUE$') ) ; 

CALL PRINT( . ( TAB , ' OR ENTER AN "s" TO 

TERMINATE. $')) J 

CEAR = 0 ; 

DO WHILE (CHAR <> CR ) AND (CHAR <> 'S'); 

CALL PRI NT ( . (CR.LF, '?$') ); 

CHAR = MON2(1,0); 

end; 

IF CHAR = CR THEN 

do; 

PROGRAM$ COUNTER = PROG RAM $ COUNTER - 1? 
C $BYTE ( 0 ) = TEMP; 

end; 

ELSE CALL STOP? 

end; 

/# 25: LDI */ 

do; 

C $ADDR ( 2 ) = 

CONVERT$TO$HEX( RES ( C$ADDR (0 ) ) , C$EYTE ( 2 ) ) + l; 
CALL INC$PTR(3); 

end; 

/* 26: DIS */ 

CALL display; 

/* 27: DEC */ 

do; 

IF C$ADDR( 0 ) <> 0 THEN 

C$ADDR(0) = C$ADDR(0) - 1J 
IF C $ADDR( 0) = 0 TEEN 

PROGRAM $ COUNTER = C$ADDR(1); 

ELSE CALL INC$PTR(4); 

end; 

/* 28: STO */ 

do; 

CALL STORE$NUMERIC; 
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CALL IN C$PTR( 4) J 



end; 

/* 29: ST1 */ 

do; 

CALL STORE$NUMERIC? 

CALL SET$ZONE ( RES (C $ADDR ( 0 ) ) ) J 

end; 

/* 30: ST2 */ 

do; 

CALL STORE$NUMERICJ 

CALL SET$ ZONE (RES ( C$ADDR ( 2 ) ) + C iEYTE (2 ) - 1); 

end; 

/* 31: ST3 */ 

do; 

call check$decimal; 

BASE = RES ( C$/DDR( 0 ) ) + C$BYTE(2) - l; 

CALL STORE$AS$CHAR (C $BYTF (2 ) - 1); 

CALL SET$SIGN$SEP(RES (C$ADDR(0) ) ) ; 

end; 

/* 32: ST4 */ 

do; 

call chece$decimal; 

BASE = RES (C$ADDR (0 ) ) + C*BYTE(2) - 2? 

CALL STORE$AS $CHAR ( C$BYTE (2 ) - 1); 

CALL SI T$S IGN $SEP 

(RES ( C $ADDR ( 0 ) ) + C$BYTE(2) - 1); 

end; 

/* 33: ST5 V 

do; 

CALL CBECK$DECIMAL; 

IF SIGN0(2) = 0 THEN 

R2(9) = R2 ( 9 ) OR 01HJ 
IF C$BYTE(4) <> SER OR NOT OVERFLOW TEEN 
DO? 

CTR = C$3YTE (2 ) / 2 + 1? 

CALL MOVE 

( .R2 + 10 - CTR,RES(C$ADDR(0) ) ,CTR); 

end; 

CALL INC$PTR(4); 



/* 


34: 


LOD 


end; 

*/ 




/* 


35: 


LD1 


CALL 

*/ 


load$num$lit; 


/* 


36: 


LD2 


CALL 

*/ 


LOAD$N UMERIC J 








do; 





HOLD = RES (CADDR(0) ) J 
IF CEECK$FOR$SIGN(H$BYTE(0) ) THEN 

do; 

CALL SET$LOAD(POS ITIVE) ? 

CALL LOAD$NUMBERS (C$ADDR(0) ,C$BYTE(2)) J 
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end; 

ELSE 

do; 

TEMP = H$BYTE(0); 

CALL SET $ LOAD (NEGITIVE) J 
CALL LOAD$NUMBERS 

( C $ ADDR ( 0 ) + 1 , C $BYTE( 2 ) - 1); 
CALL LOAD$A$CHAR (TEMP - ZONE); 

end; 

end; 

/* 37: LD3 */ 

do; 

DCL I byte; 

HOLD = RES(C$ADDR(0) ); 

IE CHECK $FOR$S IGN ( 

CTR := H$3YTE( I := C$BYTE(2) - 1)) THEN 

do; 

CALL SET$LOAD (POSITIVE); 

I = I + i; 

end; 

ELSE 



do; 

CALL SET$LOAD(NEGITIVE) ; 

CALL LOAD $A$C EAR ( CTR - ZONE); 

end; 

CALL LOAD$ NUMBERS (C $ADDR (0 ) , I ) » 

end; 

/* 38: LD4 */ 

do; 

HOLD = RES(C$ADDR(0)); 

IF ( H$BYTE( 0 ) = ' + ') THEN 

CALL SET$ LOAD (POS ITIVE) » 

ELSE CALL SET $ LOAD (NEGITIVE ) ; 

CALL LOAD $ NUMBERS ( C$ADDR (0 ) + 1, 

C$BYTE (2 ) - 1); 



end; 

/* 39: LD5 */ 

do; 

HOLD = RES ( C$ADDR ( 0 ) ) J 
IF H$BYTE( C$BYTE(2 ) - 1) = '+' THEN 
CALL SET$LOAD ( POS ITIVE ) > 

ELSE CALL SET$LOAD (NEGITIVE ) ; 

CALL LOAD $ NUMB EPS (C$ADDR (0 ) , C$BYTE( 2 ) - 1); 

end; 

/* 40: LD6 */ 



DCL I byte; 

HOLD = RES ( C$ ADDR ( 0 ) ) ; 

IF H$BYTE (I := C$BYTE(2) / 2) THEN 
CALL SET$ LOAD (NEGITIVE) J 
ELSE CALL SET$LOAD (POS ITIVE) ; 
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BASE = BASE +9-1? 

DO CTR = 0 TO I J 

E$BYTE( CTR ) = E$BYTE( CTR) * 

end; 

BiBYTE(I) = B$BYTE ( I ) AND 0F0HJ 
CALL INC$PTR(5); 

end; 

/* 41: PER */ 

do; 

BASE = C $ADDR ( 1 ) + i; 

B$ADBR( 0) = C$ADDR(2)J 
PROGRAMS COUNTER = C$ADDR(0); 









end; 




/* 


42: 


CNU 


*/ 

CALL 


compsnumsunsigned; 


/* 


43: 


CNS 


*/ 

CALL 


comp$num$sign; 


/* 


44: 


CAL 


*/ 

CALL 


compsalpha; 


/* 


45: 


RVS 


o 





CALL SET$I$0; 

IF NOT SHR (CURRENT $FLAG ,2 ) THEN 
CALL FAT AL$ ERROR ( 'W6 ' ) ; 

IF NOT FC B $B YTE$ A ( EOF $ FLAGS OFFSET ) TEEN 
CALL REWRITE$SEO(l) ; 

CALL INC$PTR(6); 

end; 

/* 46: DLS #/ 

do; 

CALL SET$I$0; 

IF NOT SHR ( CURRENT $ FLAG , 2 ) THEN 
CALL FATAL$ERROR( 'V6 ' ) J 
IF NOT FCB$BYTE$A( EOF S FLAGS OFFS ST ) TEEN 
CALL REVRITE$SE0(3) ; 

CALL IN C$PTR ( 6 ) 5 

end; 

/* 47: RDF */ 

do; 

CALL SET$I$0; 

IF NOT CURRENT$FLAG THEN 
CALL FATAL $ ERROR ( 'W5 ' ) ; 

IF NOT FC3 $BYTE$ A ( EOF $FLAG$ OFFSET ) THEN 

CALL readstosmemory; 

CALL INC$PTR(6); 

end; 

/* 48: WTF */ 

do; 

IF C$3YTE( 6) = PAG TEEN 
CONTROL$FLAG = TRUE J 
CALL SET$I$o; 
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IF NOT SHR( CURRENT$FLAG , 1 ) THEN 
CALL FATAL TERROR ( 'W3 ' ) » 

CALL write$from$memory; 

CALL INC$PTR(6); 

CONTROL$FLAG = FALSE » 

end; 

/* 49: RVL */ 

do; 

call read$variable; 

CALL INC$PTR(6); 

end; 

/* 50: WVL */ 

do; 

call write$variable; 

CALL INC$PTR(6); 

end; 

/* 51: SCR */ 

do; 

SUBSCRIPT (C$BYTE ( 7 ) ) = C$ADDR(0) + C$ADDF(l) * 
( CON VERT $TOS HEX ( C$ADDR (2) , C$EYTE ( 6 ) ) - 1); 
CALL INC$PTR(8)J 

end; 

/* 52: SGT */ 

CALL string$compare(i) ; 

/* 53: SLT */ 

CALL STRING$COMPARE(0) ; 

/* 54: SEO */ 

CALL STRING$C0MPARE(2) ; 

/* 55: MOV */ 

do; 

CALL MOVE (RES (C$ADDR(1) ) ,RES ( C $ADDR ( 0 ) ) , 

C $ADDR ( 2 ) ) ; 

IF C$ADDR(3) <> 0 TEEN 

do; 

CALL FILL (RES (C$ADDR (0) ) + C$ADDR(2), 
C$ADDR(3) .FILLER); 

end; 

CALL INC$PTR(8); 

end; 

/* 56: RRS */ 

do; 

DCL H$FLAG BYTE*, 

H$FLAG = TRUE; 

CALL SET$I$0; 

IF SHR( CURRENT$FLAG ,1 ) THEN 
CALL FATALiERROR ( 'W5 ' ) J 
DO WHILE (NOT FCE$B YTE$ A ( EOF $FLAG$ OFFSET ) ) 
AND h$flag; 

HiFLAG = FALSE; 

CALL set$relative$key; 
call read$to$memory; 
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IF B-BYTE( 0) = HIGH-VALUE THEN 
H$FLAG = TRUE? 

end; 

CALL I NC -PTR (9 ) ; 

end; 

/* 57: WRS */ 

bo; 

CALL SET-I-0? 

IF NOT SER( CURRENT -FLAG , 1 ) THEN 
CALL FATAL$ERROR('Wl')J 

CALL ceeck-difference; 

CALL SET-RELATIVE-KEY? 

call write-from-memory; 
call inc-ptr(9); 

end; 

/* 58: RRR */ 

do; 

call set-i-o; 

IF SHR( CURRENT-FLAG,1 ) THEN 
CALL FATAL-ERROR ( 'W5 ' ) ? 

CALL SET-RAN-POINTERJ 
IF NOT INVALID THEN 

CALL READ-TO-MEMORYJ 
IF INVALID THEN 

FCB-BYTE-A ( EOF -FLAG- OFF SET ) = FALSE 5 
CALL INC$PTR(9); 

end; 

/* 59: WRR */ 

do; 

DCL DIFFERENCE ADDRESS? 

CALL SET-I-O? 

IF SHR( CURRENT-FLAG, 1 ) THEN 
do; 

CALL CHECE-DIFFEREN CF? 

CALL set-relative-xey; 

CALL write-from-memory; 

end; 

else 

do; 

IF SHR( CURRENT-FLAG, 2) THEN 

do; 

call set-ran-pointer; 
if not invalid teen 

IF (EUFF$EYTE(1 ) ) = HIC-E-VALUE THEN 

do; 

REVRITE-FLAG = TRUE? 

FCB-BYTE-A (REC-NO ) = 

fcb-byte-a(rec-no) - i; 

CALL write-from-memory; 

REWRITE-FLAG = FALSE? 

end; 
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ELSE CALL FATAL$ERROR ( 'W4 ' ) ; 

ELSE CALL FATAL$ERROR ( 'W3 ' ) 5 

end; 

end; 

CALL IN C $PTR (9)5 

end; 

/* 60: RWR */ 

do; 

CALL SET$I^O; 

IF NOT SHR( CURRENT $F LAG ,2 ) THEN 
CALL FATAL$SRROR( 'W6') ; 

REWRITE$FLAG = TRUEJ 

CALL back$one$record; 

IF NOT INVALID TEEN CALL WR IT E$FROM$ MEMORY ; 
REWRITE$FLAG = FALSE; 

CALL INC$PTR(9)5 

end; 

/* 61: DLR */ 

do; 

CALL SET$I$0; 

IF NOT SHR( CURRENT $ FLAG ,2 ) THEN 
CALL FATA Lt ERROR ( 'W6 ' ) 5 
CALL set$ran$pointer; 

REWRITE$FLAG = TRUE J 
IF NOT INVALID THEN 

do; 

FCB$BYTE$A (REC$NO ) = 

FCB$BYTE$A (REC^NO ) - 1J 
CALL WRT$EMPTY$REC; 

end; 

REWRITE $FLAG = FALSE; 

CALL IN C$PTR ( 9 ) J 

end; 

/* 62: MED */ 

do; 

HOLD = RES(C$ADDR(0) ) ; 

CALL MOVE (RES ( C $ADDR (3 ) ) , HOLD, C $ADDR(4 ) ) J 
BASE = RES(C$ADDR(1 ) ) ; 

CTB , CTR1 = 0; 

DO WHILE ( CTR1 < C$ADDR(2)) 

AND (CTR < C$ADDR(4)) ; 

CALL CHECS$EDIT(H$BYTE(CTR) )J 

end; 

DO WHILE CTR < C$ADDR(4); 

IF H$BYTE ( CTR ) = 'X' OR 
H$BYTE (CTR ) = 'A ' OR 
H$BYTE(CTR) = '9' THEN 

H$BYTE( CTR ) = FILLER; 

ELSE IF H$BYTE ( CTR ) = 'B' THEN 
E$BYTE (CTR ) = ' '; 

CTR = CTR + I? 
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end; 

CALL I NC$PTR ( 10 ) ; 

end; 

/* 63: KNE *7 

CALL move$num$edited; 

/* 64: SBR */ 

do; 

RTN$BASE = RTN$3ASE - 6J 
RTN$PTR(0) = PROGRAM$COUN TER + 6J 
RTN $PTR( 1 ) = LOW$OFFSET; 

RTN$PTR (2 ) = HI$OFFSETJ 
LOV$OFFSET = C$ADDR(1 ); 

HI $OFESET = C$ADDR(2); 

PROGRAM $COUN TER = C$ADDR(0); 

end; 

/* 65: GDP */ 

do; 

DCL OFFSET BYTE; 

OFFSET = CONVERT$TO$EEX(FES (C$ADDR(1 ) ) . 

C$BYTE ( 1 ) ) J 

IF OFFSET > C$ BYTE ( 0 ) OR OFFSET < 1 THEN 

do; 

CALL PR I NT$ERFOR ( 'GD ' ) ; 

CALL INC$PTR(SHL(C$BYTE(0) ,1) + 4) 

end; 

ELSE PROGRAM $ COUNTER = C $ADDR ( OFFSET + l)J 

end; 

/* 66: PAR */ 

do; 

HOLD = CALL$TOP; 

CALL$TOP = CALL$TOP + SHL (C $ADDR( 0 ) , 1 ) + 2 
IF CALL$TOP > RTNiBAS F - 7 THEN 
CALL FATAL$ERROR( 'CO')5 
H$ADDR( 0 ) = CALL^BASE; 

DO CTR = 1 TO C$ADDP(2); 

H$ADDR ( CTR ) = RES ( C $ADDR ( CTR ) ) J 

end; 

CALL$BASE = HOLD ? 

CALL INC$PTR(SHL(C$ADDR(0 ) ,1 ) + 2); 

end; 

END; /* END OF CASE STATEMENT #/ 

END; /* END OF DO FOREVER */ 

END execute; 

/* * * * * * * PROGRAM EXECUTION STARTS HERE *******/ 

CALL MOVE ( 00FCH , .HI$FREE$MEM ,4 ) ; 

HI$FREEiMEM = MAX$MEMORY - KI$FRFE$MEM; 

LOW$FREE$MEM = C ODE$START + LOV$FREE$ MEM + 2J 
RTN$BASE = HI$FREE$MEM; 

CALL $ TOP , CALLiBASE = LOW$FREE$MEM J 
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CALL PRINT(.('NPS MICRO-COBOL INTERPRETER VERSION 2.2$')); 
CALL PRINT( .( 'EXECUTION BEGINS*')); 

BASE = code*start; 

PROGRAM* COUNTER = R*ADDR(0); 

CALL execute; 
end; 
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COMPUTER LISTING FOR MODULE READER NP5 MICRO-COBOL 



$ TITLE('NPS MICRO-COBOL COMPILER READER') PAC-EWIBTE( 82 ) 
PAGELENGTH (63 ) 

READER: DO; 

/* COBOL COMPILER - READER */ 

/* NORMALLY LOCATED AT B003H */ 

/# GLOBAL DECLARATIONS AND LITERALS */ 



/* THIS PROGRAM IS LOADED IN WITH THE PART 1 PROGRAM 
AND IS CALLED WHEN PART 1 IS FINISHED. THIS PROGRAM 
OPENS TEE PART2.COM FILE THAT CONTAINS THE CODE FOR 
PART 2 OF THE COMPILFR, AND READS IT INTO CORF. AT 
THE END OF THE READ OPERATION , CONTROL IS PASSED TO 
TEE SECOND PART OF THF PROGRAM. #/ 



DECLARE 

LIT LITERALLY 

ADDR ADDRESS 

DCL LIT 

FCB ( 33 ) BYTE 

0 , 0 , 0 , 0 , 0 , 0 , 0 , 
I ADDRESS, 

PROC LIT 

START LIT 



'LITERALLY' , 

IN ITI AL( 100H ) , 

'DECLARE' , 

INITIALS, 'PART2 COM', 

, 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) , 

'PROCEDURE', 

'100H'? 



M0N1 : PROC (F ,A ) EXTERNAL i 
DCL F EYTE, A ADDRESS; 
END MONi; 



M0N2: PROC (F, A) BYTE EXTERNAL? 

DCL F BYTE, A ADDRESS; 

END M0N2J 



BOOT: PROC EXTERNAL; 

END boot; 

OPEN: PROC (FCB) BYTE? 

DCL FCB ADDRESS; 
RETURN M0N2(15,FCB); 
END open; 



READ: PROC (ADDR) BYTE; 

DCL ADDR ADDRESS? 

CALL MONI (26, ADDR); 
RETURN M0N2 (20,. FCB); 
END read; 



/* SET DMA ADDRESS */ 

/* READ, AND RETURN ERROR CODE */ 
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ERROR: PROC(CODE); 

DCL CODE address; 

CALL MON1 (2 f (HIGH (CODE) ) ) > 

CALL MON1 (2 t (LOW ( CODE) ) ) ; 

CALL boot; 
end error; 

/* PROGRAM EXECUTION STARTS HERE */ 

CALL MON1 ( 26 , 0100E ) J 

IF OPEN ( .FCB ) = 255 TEEN CALL ERROR ('02'); 

I = 0100HJ 

DO WHILE READ ( I ) = 0? 

1=1+ 0060HJ 

end; 

CALL MON 1 (26, 0080H); /# RESET DMA ADDRESS */ 

CALL addr; 
end; 



310 



COMPUTER LISTING FOR MODULE BUILD NPS MICRO-COBOL 



$ TITLE ( 'NPS MICRO-COBOL COMPILER BUILD') PAGEW IDTH ( 80 ) 
PAGELENGTE( 60 ) 

BUILD: DO; 

/* COBOL COMPILER - BUILD */ 

/* NORMALLY LOCATED AT 103H */ 

/* GLOBAL DECLARATIONS AND LITERALS */ 

/* THIS PROGRAM TAKES THE CODE OUTPUT FROM THE COBOL 
COMPILER AN'D BUILDS THE ENVIRONMENT FOR THE COBOL 
INTERPRETER */ 



DECLARE 




LIT 


LITERALLY 


TRUE 


LIT 


ADDR 


ADDRESS 


BASF 


ADDRESS , 


B$ADDR 


BASED 


B$BYTF 


BASED 


BOOT 


LIT 


BUFF $END 


LIT 


CHAR 


BASED 


CODE$CTR 


ADDRESS , 


CSADDR 


EASED 


C$BYTE 


BASED 


CODF^NOT^SET 


BYTE 


CUR$SYM 


ADDRESS, 


DCL 


LIT 


EXT 


LIT 


FALSE 


LIT 


FCB 


ADDRESS 


FCB^BYTE 


BASED FCB 


FCB$BYTE$A 


EASED FCB 


?ILF$TYPE (*) 


BYTE 


FOREVER 


LIT 


FREE$STORAGE 


ADDRESS, 


HASH^MASK 


BYTE 


I 


BYTE, 


INTERPSADDRESS 


A DDRESS 


I NTERP$CONTENT 


BASED 


INTERP$FCB(33 ) 


BYTE 


I $BYTE 


BASED 


HI ^OFFSET 


ADDRESS 



'LITERALLY ' , 

'l'» 

INITIAL(100H) , 

BASE ADDRESS, 

BASE (4) BYTE, 

0 * 

'100H ' , 

ADDR BYTE, 

CODE$CTR ADDRESS, 
CODE$CTR BYTE, 

INITIAL ( TRUE ) , 

'DECLARE', 

'08H ' , 

IN IT IAL ( 5CH ) , 

BYTE, 

(33) BYTE, 

DATA ( ' . C IN $ ' ) , 

'WHILE TRUE', 

IN IT IAL ( 0FH ) , 

IN ITIAL ( 3500H) , 

I NTERP$ADDRESS ADDRESS, 
INITIALS, 'CINTERP COM' , 
0 , 0 , 0 . 0 ) , 

INTERP$ABDRESS ( 2 ) EYTE , 
IN IT IAL (00H ) , 
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LOW$ OFFSET 

LOADED 

MAX^MEMORY 

NEXT$S YM 

NEXT$SYM$ENTRY 

POINT 

COLLISION 

PROC 

PROC £NAME (8 ) 
READER $ LOCATION 
STP 

SUB$FLAG 
SYMEOL 
SYMBOLS ADDR 
TOPSOFSMEMOR Y 



ADDRESS 

LIT 

ADDRESS 

ADDRESS, 

BASED N EXTSSYM 
ADDRESS, 

BASED POINT 

LIT 

BYTE, 

ADDRESS 

LIT 

BYTE 

EASED CUR$SYM ( 
BASED CUR$SYM ( 
ADDRESS 



MON 1 : PROC (F ,A ) EXTERNAL; 

DCL F BYTE, A ADDRESS; 
END MONi; 



MON 2: PROC(F,A) EYTE EXTERNAL; 

DCL F BYTE, A ADDRESS; 

END M0N2J 



PRINT$CHAR : PROC(CHAR); 

DCL CHAR BYTE? 

CALL MONI (2, CHAR); 

END printscear; 

CRLF: PROC? 

CALL PRI NT$ CHAR (13)5 
CALL PRINT$CHAR(10); 

END crlf; 

PRINT: PROC(A); 

DCL A address; 

CALL MONI (9 , A ) » 

END print; 

PRINT$NAME: PROC (ADDR); 

DCL ADDR ADDRESS? 

BASE = addr; 

I =255; 

CALL crlf; 

DO WHILE (B$3YTE ( I := I * 1) <> 
CALL PRINT$CFAR(B$BYTE(I) ); 

end; 

end print$name; 

OPEN: PROC(A) BYTE; 

DCL A address; 



INITIAL ( 00H ) , 

'10E', 

IN ITIAL ( 1C80E ) , 

ADDRESS , 

ADDRESS , 
'PROCEDURE', 

INITIAL(1C80H) , 
' 06 H ' , 

I N IT IA L ( FALSE ) , 
1) BYTE, 

1) ADDRESS, 
INITIAL (0B100H); 



' ') AND (I < 8); 
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RETURN M0N2 ( 15 , A ) » 

END open; 

CLOSE: PROC(FCB); 

DCL FCB ADDRESS? 

IE M0N2 (16, FCB ) = 255 THEN 

do; 

CALL crle; 

CALL PRINT( .( 'CLOSE ERROR ON MODULE 
CALL PRIN T$N AME ( ECB + 1); 

end; 

END close; 

REBOOT: PROC; 

addr = boot; 
call addr; 
end reboot; 

FATAL$ERROR: PROC (REASON ) ; 

DCL REASON ADDRESS; 

CALL crlf; 

CALL PRINT$CHAR ( HI GH( REASON )) ; 

CALL PRINT$CHAR (LOW (REASON)); 

CALL PRINT$NAME (FCB + 1); 

CALL PR I NT ( . FILE$TYPE ) ; 

CALL reboot; 

END FATALiERRORJ 

MOVE: PROC ( FROM , DEST, COUNT); 

DCL (FROM, DEST, COUNT) ADDRESS, 

(F BASED FROM ,D BASED DEST) EYTE; 

DO WHILE (COUNT := COUNT - 1 ) O 0FFFFH ; 

D = f; 

FROM = FROM + 1; 

DEST = DEST + i; 

end; 
end move; 

FILL: PROC(ADDR, CHAR, COUNT); 

DCL ADDR ADDRESS, 

(CHAR, COUNT, DEST BASED ADDR) BYTE J 
DO WHILE (COUNT := COUNT -1)0 0FFH ; 

DEST = char; 

ADDR = ADDR + 1J 

end; 
end fill; 

GET$CHAR: PROC BYTE; 

IF (ADDR := ADD? + 1) >= BUFFiEND THEN 
DO J 

IF M0N2 (20 , FCB) <> 0 THEN 
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AO- 



do; 

CALL crlf; 

CALL PRINT(.('END OF INPUTS'))? 

CALL REBOOT? 

end; 

ADDR = 60HJ 

end; 

RETURN CHAR? 

end get$char; 

N EXT$CHAR : PROC ; 

CHAR = getscear; 

END NEXTSCHAR J 

STORE: PROC (COUNT); 

DCL COUNT BYTE? 

IF CODFSNOT$SET then 

do; 

call crlf; 

CALL PRI NT ( . ( 'CODE ERRORS')); 

CALL next$cear; 

RETURN ; 

end; 

DO I = 1 to count; 

C$BYTE = CHAR; 
call next$cfar; 

CODE$CTR = CODESCTR + 1? 

end; 

end store; 

INI T$LOAB$ TABLE : PROC; 

FRSESSTORAGE = .MEMORY; 

CALL FILL (FREE$STORAGE, 0 ,34 ) J 
NEXTSSYM = FREESSTORAGE + 32; 

NEXT$SYM$ENTRY = 0J 

end initsload$table; 

BUILD$SYMBOL: PROC; 

DCL TEMP ADDRESS; 

TEMP = next$sym; 

IF (NEXT$SYM := . SYMBOL ( 17 ) ) > MAX$MEMORY TEEN 
CALL FATAL$ERROR( 'PS') ? 

CALL FILL (TEMP ,0,17); 

END buildssymeol; 

MATCH: PROC? 

DCL (HOLD, I) BYTE? 

HOLD = 0 ; 

DO I = 0 TO 7; 

HOLD = HOLD + PROC$NAME ( I ) J 

end; 

POINT = FREESSTORAGE + SHL( ( HOLD AND HASH$MASX) , 1 ) ; 
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do forever; 

IF COLLISION = 0 THEN 

do; 

CUR$SYM , COLLI SI ON = NEXT$SYM,’ 

CALL build$symbol; 

DO I =0 TO ?; 

SYMBOL ( I + 8) = PROC$NAME(I); 

end; 

return; 

end; 

ELSE 

ro; 

cur.$sym = collision; 

i = 0 ; 

DO WHILE SYMBOL ( I + 8) = PROCSNAME(I) 
IF (I := I + 1 ) > 7 THEN 

do; 

CUR$SYM = collision; 
RETURN ; 

end; 

end; 

end; 

point = collision; 

end; 

end match; 

STUFF: PROC; 

DCL (HOLD, TEMP) ADDRESS; 

HOLD = symbolhddr(i); 
base = .temp; 

B$EYTE(0) = GET$CEAR; 

B$BYTE(1) = GET$CHARJ 

SYMBOL^ADDP. ( 1 ) = CODE$CTR + TEMP - I NTERP$ ADDRESS 
DO WHILE HOLE <> 0; 

BASE = hold; 
fold = b$addr; 

DO I = 1 TO 3? 

B$ADDP. = SYMBOL$ADDR( I ); 

BASE = BASE + 2J 

end; 

end; 

CODE4CTR = SYMBOL^ADDR(l); 

END stuff; 

COMPUTE$OFFS ETS : PROC; 

DCL TEMP ADDRESS; 

BASE = .temp; 

B$BYTE(0 ) = GET$CHARJ 
BSBYTE(l) = GETiCHARJ 

HI$OFFSET = HISOFFSET + (TOP$OF$MEMORY - TEMP + 1 
LOW$ OFFSET = CODE$CTR - INTERP$ADDRESS - 2; 
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END COMPUTES OFFSETS i 

SUBR : PROC; 

DCL I bite; 

CALL STORE(l); 

DO I = 0 TO ?; 

procsnameU) = char; 

CALL NEXTSCHAR; 

end; 

call match; 

DO I = 1 TO 3; 

CSADDR = SYMPOL$ADDR(I ) ; 
CODE$CTR = CODESCTR + 2J 

end; 

IF SYMBOL (LOADED) = 0 THEN 

SYMBOLS ADDR ( 1 ) = CODESCTR - 6; 
END subr; 

GOSDEPENDINC: PROC; 

CALL STORE(l )J 

CALL S TORE( S EL ( CHAR , 1 ) + 4); 

END goSdepending; 

PARAMETERS: PROC ; 

CALL STORE(l )j 

CALL STORE(SHL(CEAR,l ) + 2); 

END parameters; 

BACKSSTUFF: proc; 

DCL (HOLD, STUFF) ADDRESS; 

BASE = .hold; 

DO I = 0 TO 3; 

BSBYTE(I) = GETSCEAR; 

end; 

do forever; 

BASE = HOLD + LOW$OFFSET; 

HOLD = bsaddr; 
bsaddr = stuff; 

IF HOLD = 0 THEN 

do; 

call nextschar; 
return ; 

end; 

end; 

END BACKSSTUFF; 

INITIALIZE: PROC; 

DCL (COUNT, WHERE, HOWSMANY) ADDRESS ; 
EASE = .where; 

DO I = 0 TO 3; 

bSbyte(i) = getschar; 
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end; 

IF WEERE > TOP$OF$MEMORY - HI $OFFSET THEN 
BASE = WHERE - HI $OFFSET - 1? 

ELSE 

BASE = WHERE + LOW$OFFSET - l; 

DO COUNT = 1 TO eow$many; 

B$BYTE( COUNT ) = GETSCHARJ 

end; 

call next$cfar; 
end initialize; 

TERMINATE: PROC ; 

DCL I BYTE, TEMP ADDRESS t 
IF SUB$FLAG THEN C$BYTE - EXTJ 
ELSE C $BYTE = STPJ 
CODE$CTR = CODE$C TR + 1J 
I = 0FFE; 

CALL PRINT$NAME(FCB + 1); 

CALL PR I NT ( . ( ' LOADED$ ' ) ) ; 

SUB^FLAG = FALSE; 

DO I = 0 TO 15; 

POINT = FREESTORAGE + 2 * i; 

DO WHILE COLLISION <> 0; 

CUR$S YM = collision; 

IF SYMBOL(LOADSD) = 0 THEN 

do; 

CODE$NOT$SET , SYMBOL (LOADED ) ,SUB$FLAG 

true; 

CALL COMPUTE £ OFF SETS J 
SYMBOL$ADDR ( 2 ) = LOW$OFFSET; 
SYMBOL$ADDR ( 3 ) = HI $OFFSET; 

CALL CLOSE(FCB); 

CALL MOVE( .SYMBOL (8 ), FCB + 1,8); 
FCB$BYTE$A( 32 ) = 0; 

CALL FILL(FCB + 12,0,4); 

ADDR = 100HJ 

IF OPEN (FCB) = 255 THEN 

CALL FATALiERP.OR('OP') J 
CALL next$char; 

RETURN ; 

end; 

point = collision; 

end; /* DO WHILE COLLISION <> 0 */ 

END; /* DO I = 0 TO 15 */ 

END terminate; 

START$CODF: PROC ; 

CODE$NOT$SET = FALSE; 

IF SUB$FLAG TEEN CALL STUFF; 

ELSE 

do; 



31 ? 



I$BYTE (2 ) = GETSCHARJ 
I $B YTE( 1 ) = GET$CHAR; 
CODESCTR = intepp$content; 

end; 

call next$char; 
end start$code; 

EUILD : PROC; 

DCL 



F2 


LIT 


'9' 


F3 


LIT 


'10 


F4 


LIT 


'22 


F5 


LIT 


'26 


F6 


LIT 


'34 


F7 


LIT 


'41 


F8 


LIT 


'51 


F9 


LIT 


'51 


F10 


LIT 


'56 


Fll 


LIT 


'62 


F12 


LIT 


'63 


F13 


LIT 


'63 


SBR 


LIT 


'64 


GDP 


LIT 


'65 


PAR 


LIT 


'66 


I NT 


LIT 


'67 


EST 


LIT 


'68 


TER 


LIT 


'69 


SCD 


LIT 


'70 



do forever; 





IF 


CHAR 


< 


F2 


THEN 


CALL 


store(i); 


ELSE 


IT? 


CHAR 


< 


F3 


THEN 


CALL 


STORE ( 2 ) » 


ELSE 


IF 


CHAR 


< 


F 4 


THEN 


CALL 


STORE ( 3 ) ; 


ELSE 


IF 


CHAR 


< 


F5 


THEN 


CALL 


STORE ( 4 ) J 


ELSE 


IF 


CHAP 


< 


F 6 


THEN 


CALL 


STORE ( 5 ) » 


ELSE 


IF 


CHAR 


< 


F7 


THEN 


CALL 


STORE ( 6 ) ; 


ELSE 


IF 


CHAR 


< 


F8 


THEN 


CALL 


STORE ( 7 ) ; 


ELSE 


IV 


CHAR 


< 


F9 


THEN 


CALL 


STORE ( 8 ) ; 


ELSE 


IF 


CHAR 


< 


FI 0 


THEN 


CALL 


STORE ( 9 ) ; 


FLSE 


IF 


CHAR 


< 


Fll 


THEN 


CALL 


STORE ( 10 ) ? 


FLSE 


IF 


CHAR 


< 


F12 


THEN 


CALL 


STORE (11 ) ; 


ELSE 


IF 


CHAR 


< 


FI 3 


THEN 


CALL 


STORE ( 12 ) ; 


FLSE 


IF 


CHAR 


< 


SBR 


THEN 


CALL 


STORE ( 13 ) ; 


FLSE 


IF 


CHAP 


= 


SBR 


THEN 


CALL 


SUBR ; 


ELSE 


IF 


CHAR 


= 


GDP 


THEN 


CALL 


GO $ DEPEN DIN C- 


ELSE 


IF 


CHAR 


= 


PAR 


THEN 


CALL 


PARAMETERSJ 


ELSE 


IF 


CHAR 


= 


BST 


THEN 


CALL 


backsstuff; 


ELSE 


IF 


CHAR 




INT 


THEN 


CALL 


initialize; 


ELSE 


IF 


CHAR 


= 


TER 


TEEN 







do; 

call terminate; 
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IF NOT SUB$FLAG THEN 

do; 

CALL COMPUTESOFFSETSJ 
CALL CLOSE(FCB); 

return; 

end; 

end ; 

ELSE IF CHAP = SCD THEN CALL START$CODE5 
FLSE 

do; 

call crlf; 

CALL PRINT( . ( 'LOAD ERRORS'))*, 

CALL next$char; 

end; 

end; 

end euild; 

/* PROGRAM EXECUTION STARTS HERE */ 

call crlf; 

CALL PRI NT ( . ( 'NPS MICRO-COEOL LOADER VERS 2.0$')); 
ECB$BYTE$A(32) = 0; 

CALL MOVE( . ( 'CIN',0,0,0,0) ,FCB + 9,7); 

IF OPEN ( FCB ) = 255 THEN 

do; 

CALL crlf; 

CALL PR INT$NAME(FCB + 1); 

CALL PR I N T ( .FILE$TYPE) J 
CALL reboot; 

end; 

call next$cear; 
call init$load$table; 
call build; 

CALL MOVE( . I NTERP$ FCB , FCB , 32 ) J 
FCB$BYTE$A (32 ) = 0? 

IF OPEN (FCB ) = 255 THEN 

do; 

C 4. LL CR LF 5 

CALL PRINT( .( 'CINTERP.COM NOT FOUNT $')) 
CALL reboot; 

end; 

CALL MOVE(READER$LOCATION, 80H, 80H)*, 

CALL MOVE( .HI $OFFSET , 0ECE , 4) J 
ADDR = 80H; 

CALL ADDR? /* BRANCH TO 80H */ 

end; 
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COMPUTER LISTING FOR MODULE INTRDP NPS MICRO-COBOL 



$ TITLE('NPS MICRO-COBOL COMPILER INTRDR ' ) PAGEWIDTE(£0) 
PAGELENGTH ( 60 ) 

INTRDR: DOJ 

/* COBOL COMPILER - INTRDR */ 

/* NORMALLY LOCATED AT 80 H */ 

/* GLOBAL DECLARATIONS AND LITERALS */ 

/* THIS PROGRAM IS CALLED BY THE BUILD PROGRAM AFTER 
CINTERP.COM HAS BEEN OPENED, AND READS THE CODE INTO MEMORY 
V 



MON 1 :PROC ( F , A ) EXTERNAL; 

DCL F BYTE, A ADDRESS J 
END MONi; 

M0N2: PROC (F ,A ) BYTE EXTERNAL; 

DCL F BYTE, A ADDRESS; 

END M0N2J 

DO WE I LE 1 J 

CALL MONI (26,(1 := I + 0080H)); /* SET DMA ADDRESS */ 
IF M0N2 (20 ,5CH ) <> 0 THEN 



DECLARE 



LIT LITERALLY 
DCL LIT 
I ADDRESS 

INTERP ADDRESS 
PROC LIT 
START LIT 



'LITERALLY', 
'DECLARE', 
INITIAL (0080H) 
IN IT IAL( 100H ) , 
'PROCEDURE' , 
'100H'; 



CALL INTERP? 



end; 



end; 
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COMPUTE? LISTING FOR MODULE DECODE NPS MICRO-COBOL 



$ TITLE ( 'NPS MICRO-COBOL COMPILER DECODE') PAGEWI DTH (80) 
?AGELENGTE(60 ) 

DECODE: DO » 

/# COEOL COMPILER - DECODE */ 

/* NORMALLY LOCATED AT 103H */ 

/* GLOEAL DECLARATIONS AND LITERALS */ 



/* THIS PROGRAM TAKES THE CODE OUTPUT FROM TEE COBOL 
COMPILER AND CONVERTS IT INTO A READABLE OUTPUT TO 
FACILITATE DEBUGGING */ 



DCL 


LITERALLY 


'DECLARE ', 


LIT 


LITERALLY 


'LITERALLY', 


ADDR 


ADDRESS 


INITIAL (100H 


BUFF$END 


LIT 


'0FFE ' , 


BYTE$COUNT 


ADDRESS 


IN ITIAL( 0 ) , 


BYTE^HI 


BYTE, 




BYTE$LOW 


BYTE, 




CHAR 


BASED ADDR 


BYTE, 


C^ADDR 


BASED ADDR 


ADDRESS, 


FCB 


ADDRESS 


INITIAL ( 5CE ) 


FCB$BYTE 


BASED FCB (l) 


BYTE, 


E I LE $ TY P E ( * ) 


BYTE 


DATA ('CIN'), 


I 


BYTE, 




PROC 


LIT 


'PROCEDURE'; 



MON1 : PROC (F,A) EXTERNAL; 

DCL F BYTE, A ADDRESS; 
END MONi; 



M0N2: PROC (F,A) BYTE EXTERNAL; 

DCL F BYTE, A ADDRESS,* 

END M0N2 * 



BOOT: PROC EXTERNAL; 
END boot; 



PRINT^CHAR : PROC (CHAR); 
DCL CHAR BYTE? 

CALL MCN1(2,CEAR); 
END print$char; 
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CRLF: PROC; 

CALL PRINT$CHAR(13); 
CALL PRINTS CHAR ( 1 0 ) » 
END CRLF; 



P: PROC(ADDl); 

DCL ADD1 ADDRESS, C BASED ADDl (1) BYTE; 
CALL cflf; 

DO I = 0 TO 2J 

CALL PR INT$CHAR ( C ( I ) ) J 

end; 

CALL PRINT$CEAR( ' '); 

END p; 

GET$CHAR : PROC BYTE? 

IF ( ADDR := ADDR + 1) > 3UFF$END TEEN 

do; 

IF MON 2 ( 20 , FCB ) <> 0 TEEN 

do; 

CALL P(.('END'))J 
CALL boot; 

end; 

ADDR = 60H; 

end; 

RETURN CHAR; 

end get$cfar; 



D$CHAR : PROC (OUTPUT$BYTE ) ; 

DCL 0UTPUT$3YTE BYTE? 

IF OUTPUTSBYTE < 10 THEN 

CALL PR I NT$C EAR ( OUTPUT $ BYTE + 30H); 

ELSE 

CALL PR I NT$CFAR ( OUTPUT^ BYTE + 37H); 
END D$CEAR; 



D: PROC (COUNT); 

DCL( COUNT , J ) address; 

DO J=1 TO count; 

CALL D $ CHAR ( SHR( GET $CHAR. ,4) ) ; 
CALL D$CEAR ( CHAR AND 0FH ) J 
CALL PRINT$CEAR( ' '); 

end; 
end d; 



PRINT$REST : PROC; 
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DCL 


















E2 


LIT 


'9' 


» 












F3 


LIT 


'10 


✓ 

» 












F4 


LIT 


'22 


* 

* 












E5 


LIT 


'26 


✓ 

* 












F6 


LIT 


'34 


✓ 

f 












F7 


LIT 


'41 


✓ 

f 












ES 


LIT 


'51 


* 

f 












F9 


LIT 


'51 


✓ 

t 












F10 


LIT 


'56 


✓ 

f 












Fll 


LIT 


'62 


✓ 

f 












F12 


LIT 


'63 


✓ 

f 












SBR 


LIT 


'64 


✓ 

f 












F13 


LIT 


'63 


✓ 

f 












GDP 


LIT 


'65 


✓ 

f 












PAR 


LIT 


'66 


* 

f 












INT 


LIT 


'67 


* 

* 












BST 


LIT 


'66 


✓ 

f 












TER 


LIT 


'69 


* 

f 












SCD 


LIT 


'70 


' • 
9 












IF 


CHAR < 


F2 


THEN 


return; 








IF 


CEAR < 


F3 


THEN 


do; 


call 


d ( l ) ; 


RETURN 


end; 


IE 


CEAR < 


E4 


TEEN 


do; 


CALL 


D(2) ; 


RETURN 


end; 


IF 


CHAR < 


F5 


THEN 


do; 


CALL 


d(3) ; 


RETURN 


end; 


IF 


CHAR < 


F6 


THEN 


do; 


CALL 


D(4); 


RETURN 


end; 


IE 


CHAR < 


vr? 


THEN 


do; 


CALL 


D(5) ; 


RETURN 


end; 


IF 


CHAR < 


F8 


THEN 


do; 


CALL 


D(6) ; 


RETURN 


end; 


IF 


CHAR < 


F9 


TEEN 


do; 


CALL 


r(7) ; 


RETURN 


end; 


IE 


CHAR < 


E10 


THEN 


do; 


CALL 


d(8) ; 


RETURN 


end; 


IE 


CHAR < 


Fll 


THEN 


do; 


CALL 


d ( 9) ; 


RETURN 


end; 


IF 


CHAR < 


F12 


THEN 


do; 


CALL 


d(10); 


RETURN 


end; 


I? 


CHAR < 


El 3 


THEN 


do; 


CALL 


d ( i l ) ; 


RETURN 


end; 


IF 


CHAR < 


SBR 


THEN 


do; 


CALL 


D ( 12 ) ; 


RETURN 


end; 


IF 


CEAR = 


SBR 


TEEN 


do; 


CALL 


D ( 8 ) ; 


return; 


end; 


IE 


CHAP = 


GDP 


THEN 













do; 

CALL D(l); 

CALL D ( SEL ( CHAR , 1 ) + 3); 

return; 

end; 

IE CEAR = PAR THEN 

do; 

CALL D(l); 

CALL D ( SHL ( CHAR , 1 ) + 1); 

return; 

end; 

IE CHAR = INT THEN 

do; 

EYTE$COUNT = 0; 

CALL D(3); 
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BYTE$LOW = CHAP.; 

CALL D (1 ) ; 

BYTE$EI = CEARJ 
BYTF$COUNT = BYTESHIJ 

BYTE$COUNT = SHL ( BYTEiCOUNT , 8 ) + BYTFSLOW 
CALL D(BYTESCOUNT) ; 

RETURN ; 

end; 

IF CHAR = BST THEN 

do; 

CALL D(4)J 
RETURN ; 

end; 

IF CHAR = TER THEN 

do; 

CALL D(2); 

CALL P(.( 'END')); 

CALL boot; 

end; 

IF CHAR = S CD THEN 

do; 

CALL D(2); 

return; 

end; 

CALL P( .( 'XXX')); 

END print$rest; 



/* PROGRAM EXECUTION STARTS HERE */ 

FCB$BYTE(32) f FCB$BYTE(0) = 0? 

DO 1=0 TO 2 ; 

FCB$BYTE( I+9)=FILE$TYPE(I); 

end; 

IF M0N2(15,ECB)=255 THEN DOJ CALL P(.('ZZZ'))J 

call boot; end; 



DO WHILE i; 

IF GET$CHAR <= 70 THEN DO CASE CHAR 5 
J /* CASE 0 NOT USED */ 

CALL P( . ( 'ADD')); 

CALL P( . ( 'SUB') )J 
CALL P(.('MUL')); 

CALL P( .('DIV')); 

CALL P(. ('NEG')); 

CALL P( . ( 'STP')); 

CALL P(.('STI'))J 
CALL P(.('EXT'))J 
CALL P( . ( 'RN D ' ) ) ; 

CALL P( . ( 'RET')); 
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CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 
CALL P( 



. ('CLS ')) 
. ( 'SER ' ) ) 
.('BRN')) 
. ('OPN')) 
.('OP1')) 
.( '0P2')) 
. ('RGT') ) 
. ( 'RLT ' ) ) 
.('REQ')) 
. ( 'INV ' ) ) 
.('EOR')) 
.('PAG')) 
. ('ACC')) 
. ( 'STL') ) 
. ( 'LDI ' ) ) 
. ( 'DIS') ) 
. ( 'DEC ') ) 
.('STO')) 
. ( 'ST1 ' ) ) 
. ( 'ST2 ' ) ) 
. ( 'ST3 ' ) ) 
. ( 'ST4 ' ) ) 
. ( 'ST5 ' ) ) 
.('LOD')) 
.('LDI')) 
. ( 'LD2 ') ) 
. ( 'LD3 ' ) ) 
. ( 'LD4') ) 
. ( 'LD5 ' ) ) 
. ( 'LD6 ' ) ) 
. ( 'PER') ) 
. ( 'CNU ' ) ) 
. ( ' C N S ' ) ) 
. ('CAL') ) 
. ( 'RVS ') ) 
. ( 'DLS ' ) ) 
. ( 'RDE ' ) ) 
. ( 'VTF ' ) ) 
. ( 'RVL ' ) ) 
. ('WVL') ) 
.('SCR')) 
.('SGT')) 
. ( 'SLT ' ) ) 
.('SEO')) 
.('MOV')) 
. ( 'RRS ' ) ) 
. ( 'V/RS ' ) ) 
. ( 'RRR ' ) ) 
. ( 'WRR ' ) ) 
. ( 'RWR ' ) ) 
. ( 'DLR ' ) ) 
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CALL P(.('MED'))? 

CALL P( . ( 'MNE'))? 

CALL P( . ( 'SER') ); 

CALL P( . ('CDP') ); 

CALL P( . ( 'par') )? 

CALL P(.('INT'))? 

CALL P( . ( 'BST') )? 

CALL P(.('TFR'))? 

call p( .( 'scr')); 

END; /* OF CASE STATEMENT */ 
CALL print$rest; 

END? /* END OF DO WHILE V 
END? 
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SHAMMER FOR PART ONE NPS MICRO-COBOL 



OPTIONS ( BNF TABLES LALR AINPUT EXTRAT NOC-POST COMPACT) 



1 

2 

2 

3 

4 

5 

6 

7 

8 
9 

10 

11 

12 

13 

14 

14 

15 

16 
16 

17 

18 
19 

19 

20 
21 
22 
22 

23 

24 

25 

26 

27 

28 

29 

30 

31 

32 

33 

34 

35 

36 

37 

38 

39 

40 



<PROGRAM> ::= <ID-DIV> <E-DIV> <D-DIV> PROCEDURE 
<ID-DIV> ::= IDENTIFICATION DIVISION . PROGRAM-ID . 

<COMMENf> . <ID-LIST> 

<ID-LIST> ::= <AUTH> <INS> <DATE> <SEC> 

<"AUTE> : := AUTHOR . <COMMENT> . 

<EMPTT> 

<INS> ::= INSTALLATION . <COMMENT> . 

<EMPTT> 

<DATE> ::= DATE-WRITTEN . <COMMENT> . 

<EMPTT> 

<SEC> ::= SECURITY . <COMMENT> . 

<EMPTY> 

<COMMENT> : := <INPUT> 

<COMMENT> <IN?UT> 

<E-DIV> ::= ENVIRONMENT DIVISION . CONFIGURATION 

SECTION . <SP.C-OBJ> <I-0> 

<EMPTY> 

<SRC-OBJ> ::= SOURCE-COMPUTER . <COMMENT> <DEBUG> . 

OBJECT-COMPUTER . <COMMENT> . 
<DEBUG> ::= DEBUGGING MODE 
<EMPTY> 

<I-0> ::= INPUT-OUTPUT SECTION . FILE-CONTROL . 
<FILE-CONTROL-LIST> <IC> 

<EMPTY> 

<FILE-CONTROL-LlST> ::= <FI LE-CONTROL-ENTRY> 

<FILE-CONTROL-LIST> 

<^Fi LE— C ON TRO L— EN TRY > 

<FILE-CONTROL-ENTRY> ::= SFLECT <ID> <ATTRIBUTE-LIST> 
<ATTRIBUTE-LIST> ::= <ONE-ATTRIB> 

<ATTRI BUTE-LI S T> <ONE-ATTPIB> 
<ONE-ATTRIB> ::= ORGANIZATION <ORG-TYPE> 

ACCESS <ACC-TYPE> <RELATIVE> 

ASSIGN < I NPUT> 

<ORG-TYPE> ::= SEQUENTIAL 

RELATIVE 

INDEXED 

<ACC-TYPE> ::= SEQUENTIAL 

RANDOM 

<RELATIVE> ::= RELATIVE <ID> 

<EMPTY> 

<IC> ::= I-O-CONTROL . <SAMS-LIST> 

<EMPTY> 

<SAME-LIST> ::= <SAME-ELEMENT> 

<SAME-LIST> <SAME-ELEMENT> 
<SAME-ELEMENT> ::= SAME <ID-STRING> . 
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41 

42 

43 

43 

44 

45 

46 

4? 

48 

46 

49 

50 

51 

52 

53 

54 

55 

56 

57 

58 

59 

63 

60 

61 

62 

63 

64 

65 

65 

66 

66 

67 

68 

69 

70 

71 

72 

73 

74 

75 

76 

77 

78 

79 

30 

81 

82 

83 

84 

85 

86 



<ID-STRING> 



<D-DIV> 



<ID> 

<FILE-SECTION> O/0RK> 



<FILE-LIST> 



:= < ID> 

<ID-STRIMG'> 

::= DAT/ DIVISION . 

<LINK> 

<FILE-SECTION> ::= FILE SECTION 

<EMPTY> 

<FILE-LIST> ::= <FILES> 

<FILE-LIST> <FILES > 

<FILES> ::= FD <ID> <FILS-CONTROL> . 

<RECORD-DESCRIPTlON> 

::= <FILE-LST> 

< EMPTY > 

<FILE-ELEMENT> 

<FILE-LST> <FI LE-ELEMEN T> 
::= BLOCK <INTEGER> RECORDS 
RECORD <REC-COUNT> 

LAEEL RECORDS STANDARD 
LABEL RECORDS OMITTED 



<FILE-CONTROL> 
<FILE-LST> ::= 
<FI LE-ELEMEN T> 



VALUE OF < ID-STR I NG> 

<REC-C OUN T> ::= <INTEGER> 

<INTEGER> TO <INTEGER> 

<WORK> ::= WORKING-STORAGE SECTION . 

<RECORB-DESCRIPTION> 

<EMPTY> 

<LI NK> ::= LINKAGE SECTION . <RECORD-DESCRIPTION> 
<EMPTY> 

<RECORD-DESCRIPTION> ::= <LEVEL-ENTRY> 



< RECORD-DESCRIPT I ON> 
<LEVEL-ENTRY> 

<LFVEL-ENTRY> ::= <INTEGER> <DATA-ID> <REDEFINES> 

<DATA-TYPE> . 

<’DATA-ID> <ID> 

FILLER 



<REDFFI NES> ::= REDEFINES <ID> 

<EMPTY> 

<DATA-TYPE> ::= <PROP-LIST> 

<EMPTY> 

<PRO?-LIST> ::= <DATA-FLEMENT> 

<PROP-LIST> <DATA-ELEMENT> 
<DATA-ELEMENT> PIC <INPUT> 

USAGE COMP 

USAGE COMP-3 

USAGE COMPUTATIONAL 

USAGE DISPLAY 

SIGN LEADING <SEPARATE> 

SIGN TRAILING <SE?ARATF> 
OCCURS <INTEGER> INDEXED <ID> 
OCCURS <INTEGFR> 

SYNC <DI RFCT I ON> 

VALUE <LITERAL> 

<DIPECTION> ::= LEFT 
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B? 

88 



RIGHT 



92 

93 

94 

95 



89 <SEPARATE> 

90 

91 <LITERAL> 



<EMPTY> 
= SEPARATE 
<Ef“!PTY> 
<INPUT> 
<LIT> 

ZERO 

SPACE 

QUOTE 



96 <INTEGFR> : := <INPUT> 
9? CIO ::= <INPUT> 



Note that the options list ^contains the item NOGPOST. 
This elimenats the hoal symbol from being added to 
the grammer of part one. In part two the hoal symbol is 
used as an end of file symbol (EOF). 
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GRAMMER EOR PART TWO NPS MICRO-COBOL 



OPTIONS ( 3N? TABLES LALR AINPUT EXTRAT COMPACT ) 



1 

2 

3 

4 

5 

6 
? 
8 
9 

10 

11 

12 

13 

14 

15 

16 

17 

18 

19 

20 
21 
22 
22 

23 

24 

25 

26 

27 

28 

29 

30 

31 

32 

33 

34 

35 

36 

37 

38 

39 

40 

41 

42 

43 

44 



<P-DIV> ::= PROCEDURE DIVISION <USING> . <PROC-BODY> 
<US I NG> ::= USING <ID-STRING> 

<EMPTY> 

<ID-STRING> <ID> 

<ID-STRING> <ID> 

<PROC-BODY> ::= <PARAGRAPH> 

<PROC-BODY> <PARAGRAPE> 

<PARAGRAPH> ::= <ID> . 

< ID> . <SENTENCE-LlST> 

<ID> SECTION . 

<SENTENCE-LIST> ::= <SENTENCE> . 

<SENTENCE-LIST> <SENTEN CE> . 
<SENTENCE> ::= <IMPERATIVE> 

<CONDITIONAL> 

ENTER <ID> <OPT-ID> 

<1 ^PERATI VE> ::= ACCEPT <SUBID> 

<ARI THMETIO 

CALL <CALL-LIT> <USING> 

CLOSE <CLOSE-LST> 

<EI LE-ACT> 

DISPLAY <DISPLAY-LST> 

DISPLAY <DISPLAY-LST> WITH NO 
ADVANCING 
EXIT <PROGRAM-ID> 

GO <ID> 

GO <ID-STRING> DEPENDING <ID> 

MOVE <LI T/ID> TO <SUBID> 

OPITM ✓ * PT— T 

PERFORM <ID> <THRU> <^INISH> 

STOP <TERMI NATF> 

<CLOSE-LST> ::= <ID> 

<CLOSE-LST> <ID> 

<DISPLAY-LST> ::= <LIT/ID> 

<DISPLAY-LST> <LIT/ID> 

<ACT-LST> ::= <TYPE-ACTI ON> <0PEN-LST> 

<ACT-LST> <TYPE-ACTION> <OPEN-LST> 
<OPEN-LST> : := <ID> 

<OPEN-LST> <ID> 

<F I N ISH> ::= <L/ID> TIMES 

<STOPCONDITION> 

<VARYI NG> <ITERAT ION > <S TOPCON DI TI ON > 
<EMPTY> 

<STOPCOND IT ION > : := UNTIL <CONDITION> 

<VARYI NG> ::= VARYING <SU3ID> 

<ITERATION> ::= <EP.OM> <EY> 
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<FROM> ::= FROM <L/ID> 

<BY> ::= BY <L/ID> 

<COND IT IONAL> ::= <ARI THMFTI C> <SIZE-EPROR> 

<IMPERATIVE> 

<FILE-ACT> <1 N VALI D> <IMPERATIVE> 
<READ-ID> <S PEC IA L> <IMPERATIVE> 

< I F-N 0 N TE R MI N AL > <CONDITION> 

<IF-LST> <ELSE> <IF-LST> FND-IF 
<IF-NONTERMINAL> <CONDITION> 

<IF~LST'> ENE-IF 

<IF-LST> ::= <STMT-LST> 

NEXT SENTENCE 
<EISE> ::= ELSE 

<API THMET I C> ::= ADD <ADD-LST> TO <SUBID> <ROUND> 

ADD <ADD-LST>GIVING <SUBID> <ROUND> 
DIVIDE <L/ID> INTO ^SUBID> <RCUND> 
DIVIDE <L/ID> BY <SU3ID> GIVING 
<SUBID> <ROUND> 

DIVIDE <L/ID> INTO ^SUEID^ GIVING 
<SUBID> <ROUND> 

MULTIPLY <L/ID> BY <SUBID> <ROUND> 
MULTIPLY <L/ID> BY <SUEID> GIVING 
<SUBID> <ROUND> 

SUBTRACT <SUB-LST> FROM <SUBID> 
<ROUND> 

SUBTRACT <SUB-LST> GIVING <SU3ID> 
<ROUND> 

COMPUTE <SUBID> = <ARITH-EXP>. 
<ADD-LST> ::= <L/ID> 

<ADD-LST> <L/ID> 

<SUE-LST> ::= <L/ID> 

<SUB-LST> <L/ID> 

<ARITE-EXP> ::= <TERM> 

<ARITH-EXP> + <TERM> 

<ARITH-EXP> - <TERM> 

+ <TEP.M> 

- <TERM> 

<TERM> ::= <PRIMARY> 

<TERM> * <PRIMAP.Y> 

<TERM> / <PRIMARY> 

<PRIMARY> <PRIM-ELEM> 

<PRIMARY> ** <PR IM-ELEM> 

<'PRIM-ELEM> <L/ID> 

( <ARITH-EXP> ) 

<FILE-ACT> ::= DELETE <ID> 

REWRITE <ID> 

WRITE <ID> <SPECIAL-ACT> 

<CONDITION> <BTEEM> 

<CONDI TI ON > OR <BTERM> 

<BTERM> ::= <BPRIM> 

<BTERM> AND <BPRIM> 
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<BPR IM> : := <LIT/ID> 

<LIT/ID> <NOT> <COND-TYPE> 

( <PTERM> ) 

<COND-TYPE> ::= NUMERIC 

ALPHABETIC 
<COM?ARE> <LIT/ID> 

<NOT> : := NOT 

<EMPTY> 

<COMPARE> : := GREATER 
LESS 
EQUAL 
> 

< 

<R0UND> : := ROUNDED 
<EMPTY> 

<TERMINATE> ::= <LI TERAL> 

RUN 

<SPECIAL'> ::= <INVALID> 

END 

<OPT-ID> : := <SUBID> 

<EMPTY> 

<STMT-LST> ::= <IMPERATIVE> 

<STMT-LST> <1 MPERATI VE> 
<CONDITIONAL> 

<STMT-LST> <CONDITIONAL> 

<THRU> THRU <ID> 

<EMPTY> 

<INVALID> ::= INVALID 
<SIZE-ERROR> ::= SIZE ERROR 

<SPECIAL-ACT> ::= <VHEN> ADVANCING <HOW-MANY> 

<EMPTY> 

<W5EN> BEFORE 

AFT^R 

<E OW-MA NY> ::=<INTEGER> 

PAGE 

<TYPE-ACTION> ::= INPUT 

OUTPUT 

1-0 

<SU3ID'> ::= <SU3SCRIPT> 

<ID> 

<INTEGER> ::= <INPUT> 

<ID> ::= < INPUT> 

<L/ID> ::= <INPUT> 

<SUBSCRIPT> 

ZERO 

<SUBSCR IPT> ::= <ID> ( <SU3SCRIPT-LST> ) 
<SUBSCRIPT-LST> : := <INPUT> 

<SU3SCPIPT-LST> , <INPUT> 

<CALL-LIT> ::= <LIT> 

<NN-LIT> <LIT> 
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139 




SPACE 


140 




QUOTE 


141 


<LITERAL> : : 


= <NN-L IT> 


142 




<INPUT> 


143 




ZERO 


144 


<LIT/ID> : : = 


<L/ID> 


145 




<NN-LIT> 


146 


<PROGFAM-ID> 


::= <1 D> 


14? 




<EMPTY> 


148 


<REJD-ID> :: 


= READ <ID> 


149 


< IF- NONTERMINAL ::= IF 



Note that the options list does not contain the item 
NOGPOST. This causes a goal symbol to be added to 
the grarrmer at the end of nroduction one. This symbol is 
used as the end of file symbol (EOF). Part one uses the 
optional NOGPOST to surpress the generation of the goal 
symbol since an EOF is not wanted at the end of part one. 
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